From d72ee5c52609df997e0a1aac39c926f34f62843e Mon Sep 17 00:00:00 2001 From: DmBel Date: Sat, 9 Oct 2021 12:20:01 +0300 Subject: [PATCH] first release --- Project2.dpr | 14 + Project2.dproj | 121 ++ Project2.res | Bin 0 -> 62704 bytes SynHttpSrv.pas | 3332 +++++++++++++++++++++++++++++++ SynSrv.pas | 317 +++ Unit2.dfm | 25 + Unit2.pas | 86 + asn1util.pas | 521 +++++ blcksock.pas | 4603 +++++++++++++++++++++++++++++++++++++++++++ clamsend.pas | 277 +++ dnssend.pas | 603 ++++++ ftpsend.pas | 1964 ++++++++++++++++++ ftptsend.pas | 418 ++++ httpsend.pas | 866 ++++++++ imapsend.pas | 871 ++++++++ laz_synapse.pas | 18 + ldapsend.pas | 1268 ++++++++++++ mimeinln.pas | 263 +++ mimemess.pas | 851 ++++++++ mimepart.pas | 1227 ++++++++++++ nntpsend.pas | 483 +++++ pingsend.pas | 728 +++++++ pop3send.pas | 483 +++++ slogsend.pas | 320 +++ smtpsend.pas | 987 ++++++++++ snmpsend.pas | 1269 ++++++++++++ sntpsend.pas | 382 ++++ ssdotnet.inc | 1099 +++++++++++ ssfpc.inc | 926 +++++++++ ssl_cryptlib.pas | 681 +++++++ ssl_libssh2.pas | 251 +++ ssl_openssl.pas | 1007 ++++++++++ ssl_openssl_lib.pas | 2463 +++++++++++++++++++++++ ssl_streamsec.pas | 539 +++++ sslinux.inc | 1318 +++++++++++++ ssos2ws1.inc | 1843 +++++++++++++++++ ssposix.inc | 1116 +++++++++++ sswin32.inc | 1661 ++++++++++++++++ synabyte.pas | 368 ++++ synachar.pas | 2041 +++++++++++++++++++ synacode.pas | 1474 ++++++++++++++ synacrypt.pas | 2412 +++++++++++++++++++++++ synadbg.pas | 156 ++ synafpc.pas | 152 ++ synaicnv.pas | 368 ++++ synaip.pas | 422 ++++ synamisc.pas | 482 +++++ synaser.pas | 2788 ++++++++++++++++++++++++++ synautil.pas | 2161 ++++++++++++++++++++ synsock.pas | 93 + tlntsend.pas | 364 ++++ tzutil.pas | 702 +++++++ 52 files changed, 49184 insertions(+) create mode 100644 Project2.dpr create mode 100644 Project2.dproj create mode 100644 Project2.res create mode 100644 SynHttpSrv.pas create mode 100644 SynSrv.pas create mode 100644 Unit2.dfm create mode 100644 Unit2.pas create mode 100644 asn1util.pas create mode 100644 blcksock.pas create mode 100644 clamsend.pas create mode 100644 dnssend.pas create mode 100644 ftpsend.pas create mode 100644 ftptsend.pas create mode 100644 httpsend.pas create mode 100644 imapsend.pas create mode 100644 laz_synapse.pas create mode 100644 ldapsend.pas create mode 100644 mimeinln.pas create mode 100644 mimemess.pas create mode 100644 mimepart.pas create mode 100644 nntpsend.pas create mode 100644 pingsend.pas create mode 100644 pop3send.pas create mode 100644 slogsend.pas create mode 100644 smtpsend.pas create mode 100644 snmpsend.pas create mode 100644 sntpsend.pas create mode 100644 ssdotnet.inc create mode 100644 ssfpc.inc create mode 100644 ssl_cryptlib.pas create mode 100644 ssl_libssh2.pas create mode 100644 ssl_openssl.pas create mode 100644 ssl_openssl_lib.pas create mode 100644 ssl_streamsec.pas create mode 100644 sslinux.inc create mode 100644 ssos2ws1.inc create mode 100644 ssposix.inc create mode 100644 sswin32.inc create mode 100644 synabyte.pas create mode 100644 synachar.pas create mode 100644 synacode.pas create mode 100644 synacrypt.pas create mode 100644 synadbg.pas create mode 100644 synafpc.pas create mode 100644 synaicnv.pas create mode 100644 synaip.pas create mode 100644 synamisc.pas create mode 100644 synaser.pas create mode 100644 synautil.pas create mode 100644 synsock.pas create mode 100644 tlntsend.pas create mode 100644 tzutil.pas diff --git a/Project2.dpr b/Project2.dpr new file mode 100644 index 0000000..0d75b8d --- /dev/null +++ b/Project2.dpr @@ -0,0 +1,14 @@ +program Project2; + +uses + Vcl.Forms, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Project2.dproj b/Project2.dproj new file mode 100644 index 0000000..f1c8657 --- /dev/null +++ b/Project2.dproj @@ -0,0 +1,121 @@ + + + {F46C6246-B90C-4984-B610-497F767B46C6} + 15.4 + VCL + Project2.dpr + True + Debug + Win32 + 1 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + Project2 + $(BDS)\bin\delphi_PROJECTICON.ico + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + true + EurekaLogCore;JvGlobus;RVASpellPkgDXE6;JvMM;vquery200;zexmlsslib;IndyProtocols200;JvManagedThreads;pgprovider200;FireDACSqliteDriver;TestPack;uniSF20;uniSFChart20;DBXSqliteDriver;FireDACPgDriver;VCLXDBGrid200;accessprovider200;fmx;uniGUI20Core;JvDlgs;JvCrypt;TeeDB;tethering;inetdbbde;vclib;DBXInterBaseDriver;RichViewActionsDXE6;JvNet;RVIndyDXE6;JvDotNetCtrls;RvXmlDXE6;mongoprovider200;DbxCommonDriver;crcontrols200;vclimg;RVPkgDXE6;dbxcds;IndySystem200;dbfprovider200;JvXPCtrls;tdsprovider200;RvHtmlDXE6;vcldb;vcldsnap;liteprovider200;uniGUI20VCL;odbcprovider200;fmxFireDAC;dacvcl200;CustomIPTransport;JvCore;RVDBPkgDXE6;vclribbon;adsprovider200;dsnap;fmxase;vcl;dacfmx200;oraprovider200;CloudService;CodeSiteExpressPkg;FmxTeeUI;FireDACIBDriver;JvAppFrm;soapserver;JvDB;JvRuntimeDesign;inetdbxpress;dsnapxml;JclDeveloperTools;uSynEdit_R2016;JvDocking;adortl;JvWizards;FireDACASADriver;JvHMI;aseprovider200;AviPack;RVMathDXE6;uniTools20;bindcompfmx;JvBands;vcldbx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;DSPack_DXE2;FireDACCommon;bindcomp;inetdb;IndyCore200;JvPluginSystem;dac200;uniGUI20;Tee;JclContainers;tb2k_d16;JvCmp;vclFireDAC;JvSystem;xmlrtl;svnui;ibxpress;JvTimeFramework;JvControls;uniGUI20m;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;soaprtl;bindengine;vclactnband;FMXTee;TeeUI;bindcompvcl;ibprovider200;db2provider200;unidacvcl200;vclie;Jcl;JvStdCtrls;JvCustom;unidacfmx200;FireDACADSDriver;vcltouch;JvJans;JvPageComps;unidac200;myprovider200;JvPrintPreview;PngComponents;uIndy20;VclSmp;FireDAC;VCLRESTComponents;CoolTrayIconD16;Intraweb;RVHunSpellPkgDXE6;gtPDFkitDXE6ProP;dsnapcon;uniGUI20Chart;inet;fmxobj;JclVcl;JvPascalInterpreter;FireDACMySQLDriver;soapmidas;vclx;svn;fmxdae;RESTComponents;bdertl;FFmpeg_DXE6;AwSlider70;FireDACMSAccDriver;dbexpress;SpTBXLib;JvBDE;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + vquery200;IndyProtocols200;pgprovider200;FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;accessprovider200;fmx;uniGUI20Core;TeeDB;tethering;vclib;DBXInterBaseDriver;mongoprovider200;DbxCommonDriver;crcontrols200;vclimg;dbxcds;IndySystem200;dbfprovider200;tdsprovider200;vcldb;vcldsnap;liteprovider200;uniGUI20VCL;odbcprovider200;fmxFireDAC;dacvcl200;CustomIPTransport;JvCore;RVDBPkgDXE6;vclribbon;adsprovider200;dsnap;fmxase;vcl;dacfmx200;oraprovider200;CloudService;FmxTeeUI;FireDACIBDriver;soapserver;inetdbxpress;dsnapxml;uSynEdit_R2016;adortl;FireDACASADriver;aseprovider200;AviPack;uniTools20;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;DSPack_DXE2;FireDACCommon;bindcomp;inetdb;IndyCore200;dac200;uniGUI20;Tee;vclFireDAC;xmlrtl;ibxpress;uniGUI20m;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;soaprtl;bindengine;vclactnband;FMXTee;TeeUI;bindcompvcl;ibprovider200;db2provider200;unidacvcl200;vclie;unidacfmx200;FireDACADSDriver;vcltouch;unidac200;myprovider200;PngComponents;uIndy20;VclSmp;FireDAC;VCLRESTComponents;CoolTrayIconD16;Intraweb;dsnapcon;uniGUI20Chart;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;SpTBXLib;JvBDE;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form2
+ dfm + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project2.dpr + + + + + True + False + + + 12 + + + + diff --git a/Project2.res b/Project2.res new file mode 100644 index 0000000000000000000000000000000000000000..d6cf6329cd078224d25f1d767092617dce629de1 GIT binary patch literal 62704 zcmZ6y1yo$YvM9O-cXxsYcM{y)-QC?S5P}U32?V#`5FCQLI|K+G+=9FN0DsQC|NOW9 z>$Q4M@9wJVYOATLt_=VHKncxnZ~vR2#s6Ot1O2xh3km~$fhG5aZaR5kAdjEyjf#P@o zo=|L8DCU0>C%^`U`ELfGIRAlHgF?9iR=_8~658wkjrD)yNI~gejG zn*SM<7PQqI+N&p&b8{%w|HA_^+z#A+IRH>X>Abzc{(tj}h4p{tH(E_a79E8I1qy;L zFDIq(zq14akPx6XMjoX$08su*UP@f+^YV!?q8Z+&zdzP9=q?6gS1!e@jrLokoB+fgV#lEbWbiX}M{y7^zajKK&p%Tks6U@lY zZn_Sv?xqjsaVX?zvyt~`Rn3cCE{$cQXatFoHcoRZIRjHN&R*!6q<~RxgT>*DQ)GX_ zv3tAcXfD4?vthYTh3oH$$>9y{f0v(U=9sh{w7k4R?~S$fkqIhpsh4E)mFPSvME!|k z=w=D(PCOP*ZL4&S4-E=0cMM&-145k6DA^}>yC|IJ+#F!R%-~d3M*w}$syc4vUYZXv@vA5LgW(+!Q`|QV-|LHb|Jq# zrQq2^A!QNK$L=%}14W+ZgtTLijcy(k73e^I+bt#1z8I_6QbbG5)CWXjtXWuC2prxb zsFf$@%{%mazpD${sEho4c7fzpzl7$UN#@|_nD_JN&f-=mA|{TqMfa%P>dO(SYb8~t zUOqaW0eT~-$C}RSbMx3IT^*G_&S6WgG10L_F~2m*q?)Va^jl-rrY41R+Qjp^CPPnG zZ0gm`N*UNA71P*Gg}&^J?EU`z+jQOkxN3gK614%;XI;nx*qIx&*{QP^{N6}OPrgxe zFnEeZjz-R#JrrX~L2w$g<~ys4pKb|SKm>Z5%Hmp&1tIbs=|t&o2=UF4f}hSHVjdoKy;#JfNmnfOo*7+i zbS`VaCURSBP_sYStViq!79mwlu(a$~L|>o8?Dx}^1syFd|NEhyV8u~cIy>0V8tB#w zOCVr3TKpz7uIh8P`iO}vFMpU2c4)1UaqihXtW0sCHuqS83Jff42?nOkqhVpS+>h;g zi*tiQQTP9(IIVOAOf1#g?)zUImShHBk~U-@o997inwmA8m)(Fa30+Q3$-hi862sVH z``<(2`spR7NLmQzNh1=_cRKPybFU_|{&J6fZtAN~e6rSlzZ3lOY)jy@RA;rDW@-X% zdKX5gP6}`(Mj7WS6CL*dT5EfuVr8A^xn16tWKF)2D33cNg#m6~j2CKK_l*d-{~}JQ z0h>S2FGO38fdfIuqOnKhv9fC=$j7kfQ6*Awc*7roI>gxc{r&n+trw4+=MzJlmH5%$g-NMpE*$n8c{@ zVS0yb}#IP_94oBY|RkckicT4fOH#|i#{3q{95 znuA07X+rO;tj+DT*0wudP0HiX@nt-{dZgUI&Xb@C1eimdI!#1>d8Ylsv@j9D89HO! zZZ}?6;|7BV8#4_ooZG9sT*N4h!7DN$L+giO2L_PNMVnOxK1au*sW z8q<)%#?EB;K})ACVj&w_Fu(*C&085a6AHrTQ=(e_ptE=W_iH|$fkurE15dZds)_82 zTO@EHjyM1TtKO6-Gqa=jGX#Q`VxYXRC28I)=-(WU3IvvIZ~%5?3}Otqh%2c@dkA2& zVliWNuv#|wlRfZy?pKOXGV36gZ-r9pq{F<2m0YFQdUYC|M8}FaBgkNt^sdtbYeJJFR`e`;}kW=ZF9h{K*xiWM_A!OL$7qaD|Bu zmGjSBL$)KY8)roTZe-x?Kz%-cl$~vW(zo*-PX`ucP0!F>0M5{b2;gEv8-WK>M<4fq zw~suInuY42DkawAFlnfT@TvIBI{tiLP8Nx+`k7h~3gC5xfpIF0+^H;+&M%@-^S*Ki z^UZqtNva;w0N{s{r5Z|}_F{A~A1}X3asdYlZ4NO5dIwrl-T z@0QzRdJYH>wL}Gh*J-dt#XJQ;lFuucFiL4;ANjIXN=r+B9@p6I^@V?1Kj&N_j-})C ze{k!0^g3C@rlwB6pcgrN7$_+!dN4?mo~5JnVB!p4`}RO5Zk#Xr+V%wGajFAWCv81F zZ)DzN*R3*DAxHsmojhr}q@;*An!47u;40?# z+MT-R(tw4(`yY99am~7iZ6R&|U|J`cow)AQB&Mv)I`@}kYdqs4*Yxg4Lg5XSH{S`D zFfoN$suRz*;Vm~lWFkJJK#!!;%iXQ4xG*8efIy-=a^cvB;;(rbhA1m3KlzXa)+F;~ z)@}L8$;pzc@w)nY@#=-(UNfLd2X{ah%b?sf@8^CHIaE-MPXGX}_GSpkhxBa>6JU{+ zmJa!SOvA#)7C{jNxojsi{cAX$7q_O64ZJQBJ+AM8aOEyZJRC%HzEmLC*2TyBYidJ!aqNP0luut%? zxMsF6dD_Hj)5@9)seThbhY(#tixo=7Z2t5YD}&f^Ji-bcM=lcKE&omtjS8)Dno@J~ z%=)u6KQRXf6dHPZ9J8pr@cxGn zer1jISn4%%x6$KM7Id5-P3O<^T<=@U0ki48aMk_Y-Pnmgqnslnp=UHP5}!j`)!1=S zK|R&zQA@8UJ~TZkueTt;C!mwumkn3ISWUwKfe;mSYq1u0k>DFgORR!-WWNj-QN@~x zfsF=!nqJW^zRI`xa<8^EY$?5CG%4)`Y<%P60DGvehFh$qV4X*OK3?uxJiGc_lyDCXK&E&+!t7ok8)EwSX9<8CiSEHS2{D-Mo>4@^F{wE#3x+GWd zNP0R^s7^&1t{J6SJi_Tpb7*oho}66Nwf2QOh%&vH5+cL}do z`<%{;1wcdqwxsL+Afu98JiXawDk^?9WMTP{&vf;~zmaCo*P1C*vW29zygyohrd|Tk zw!h91Csnj8syO+iNWx4D6e*C%|8&4JXA6}OH&K|vP2moaGqv)D*BS9O{otYO;Su|x zx*-ikIra1M^#&og_L>y~L5j7&^~yR5ZI7#UT%{sFzu=p3$;ltdCnJ0O@xNWc9zW7;zA zPe}P8F`b8mPWNX=2U;qt;oVDKZ|F1)Ls&%*P0K&f<~RNNg6QnGPxs`)E>sSTFPBPE zM}k=@!AF16o&t;0Pyn&Mm8M@blv^GF145HZ>%H#OTbN`556$%PB7E>^L8?X;2Q|XA zLyrztmfEqKSkVN+pm*kD!`hco>Lg<0%UTD04Gn(}4}}JWqJ%u}sWMIa0;-*-jtdJw zEf+z}ha7B5dcl6}{MIu9^8kPakdOf>nGbZqDd|ZSU2m@k5AsPl%b`3=_~f)L1t7Ea zEdGIY)yKreY+}8eU@{8_2j$mqNpc|$fQ0;{_BCu#x8B2KP>k7*Unx-PLw@=I`;6He zjZ4qaU)UhKZ#0+xzOgZ!aBY_-Q@l`%0e6n1M_0%f+cEQlQ2A}8!iJjs`pkd>hTR9f zXnjk%1(gO^hDHP766e&JZz{IYtiOSrhPj8ixfr-u8D^?tQm@0AjC8coIVGraUGpO( zednInnH-ZTlf>a!L_Fr z{Y0jqk67R{B%}4z!`^K}g$85!xepRR1#q0luuWQfyL>xp`zcBRK*lP)Y@t5%nm{$8nMb(czdE1K_5}dFj#^cNc zh8j>I^9}`=Sx+~_NxM_nj_S@;9;4K~MsCa~hxp{cRGZPb0cvszoKapE_s{M@~UUz&GzCX{H?0Fpl z`X5@z`+q9&(sNP(qNV^Nhc(G;6nX--S8GctQn7L-kNN7u<@=FbX}9p;9{l?(>^+K& zcGcYf$P^7#?x8_<3syhIf52wiQzdav%F_dzRp43IKvB2p(X1?bw&hN+$fqY3r;RSy z-(w0r7M$<5{iuCTez6I8%E;VE1$;YkRN!GA^E_ zEix!lD3g%SB{K(eWn&aXe~t4N7C8S^N|Bd=3?j>pCQ@gp*Wb!p@;c;e`J?aQnds@U zTr@m5sMzLxsxSd-CDwH#ixYtmUJU-$Rd{os2{$hI6xT97*@0NB=^0l-(@iCSIQ?c- z&fUjr8q|1Lq-z=w;qOKA3u^mWs34Gv&prM1ong%$pAts|doe zok+(fBPM=SJnsr>aI zIY(QhquHyoQnqX$=^zzGqdUnVB5;qUK#RW6_>{SZ68*!MjUJsbhbvQA(5V=9Z(Iom z&X@o4Qob%n*iT%?rj5OKq~hd}frDw2-~nD}{l;Dt3GVprgg!q$LBcCJM+SxC&FW>j zk#H!6?0NAO7SUUh`J8XAJXfCL`u=cMSvj5J<1xJ(+6cjs?l#TA@4fVF7ba?tmiLi zgmuHpV3#|2^O^GyH!rh1lkw|Empwl6*VZDt_1`XlR%Vou)-7HEHl&*INqAt3p;-(C zE?6$~yA4Kxe2dHJ^0)Ug-~IoMOcxpk%Tu_dP)<4IDqFpVg@u{6d7rPNCrM>t5b8PK z+G_>d0R0e+?}e&5kqfzRg&t(GDcbW=|IQ<>_y34FJEI>&Kb`BhcYTqarZw)+p`WCW z+4zGcpY4~PPfw^d-l+Z=sTCd6Sg!rx48XIxN(1qFzKt|JG#m$?^0XLx9h!RDJ~^_-zT-Zks3L|lpasUIMqQ&I zMY`uEYg{DgtUKoY{`p22VKK`Gn@aq z2zn4bt5yg~$w(shK@N8M@rX%i>1Z}N$WZom?6=G?7 z&^`3afN8|V#Y*98et<~)4 z_v37abyhBuCY`U}6E_Y$c)^buW0%8sv<2m&nYf$Hk1t`ENy8JspRNGJ&COoex%z6V zqvD-s?s?L&uV_nOLVs#%acSS${*T|A5zzY% zda&)Jr-OBFcc`x|vnVn)q={>(&d1a<#~z$+m(w)pg_%dnbK>0V-PzNF?$5zu3E@#r~Fix9N%Yt4*j0X*b_xTL$GU0ux( zCuP4uD?oCErY?0hmW3`=`;l_t_(yS>QsAz z>8eBNu;jT7w&FeK6j+GCJx=O@iB#bNf8)D99l)KU#boCbg*}Q zZgadp`#5bP8SUi5rF2z4PGNMLc4Yv5)DS7#xySNq>bpB#*;;L_=PJ(q{FD_isVcg} zjDHp7GF>~xN|&k-kZm-bI^YS9O^2(E?Q9m>dUuik^I;j1)A?+U>=8%4W?wDIh=NcJ z?#Z1$$Gvd-+0EP|Kf;aJ@=8O)sSKpO_abRy{mz*yWIt1B|Ix-@NkjlKt<`(8PISU_ zJc~b1apBk4wta3O^&=U2##oPSAl+mx>GA%`OC@2twLgSvY>e4_rKxHslCg*>=-*`b z9K`J=icY^;*Nc99BVqB`S>x?Dt(9h_n2T4Pha$*-J=%IxGv)rk}k$r&2nH`AwGZwMgigk(if0$n0)BqqEM_2ltzY-*|@q*+{Lf`Fp^HEo|{G4^jP5 zGx~R&vCp#J+YwdF715~cTjuCzCtV38`4W+ZwXDn)jH|2V>C}BRq>+xvRC=*fS>+y6 zg_FIo7-1?w1ot-s^w}3XMRD<4s1sB4)82T-ZBGoXpfFtbF1e!S)}3VLUD88@pC;Nw=Ek&$9DywoZ+ zv*zy~(KHeEnpdSW}jl`nVyugzp!k~ns z%_+dI?fYy51??53nFhvGt|Ka~iG7=~27z1aZR5^oo6p}kRwH9Ji1rA14mV-J zEnf3EKh4N!RbOlODVh+8XXYr$wU_9NKw5+O2);ygTS-6_r>toie={me_J~ii#p@5f z-k;pyIGI(=rLTySM3qG_fXLI2zj+O-WZMo63{CY%{(_HQh-ooUhdYC3GAv#C>9Q|DbT1Ov!I=<+cQ_DX)~G5?a0vJW|b$M zd!I2|au2;ZF@ZXtqbJspt`#MlpQIh`TC2JikpM%2-w?HNOidjfjOV*kP*NGe91p3M za*j!BW0OFes||tq>*pWC)v3m7CV~BhK_LF7zZ&Hsu3;)1DFP4sBX~aqM23|+s=62x zHU`|!V3K2dbe@8{y>_Y{OjL4{oe8Pem!NTOtbkr z*_EJ}k`vcF12$mwfgdRV#;9zP8&NNok`HkEF(2QZqEKvbvsk-*r(P)AS?|5p_P8@? zVMkSB_6?>-cP#Dvc(F)PSD<9FzneHmARavZG}!sN>eBsS(cbgHo5cKe#$!=2o#Oeb zC|SFw>#&|F`h_sS*hNsRQ51icyZQ<%mum)K)THm(t$9#be?~fyjYF)|{d5d-8M<*( zO{rup>;=aHhsJ`0z|GC-{oToY`byXjeky#0G(H`aS=B-RIttK^hvbx`2MpS zjbyjX71xqf-M-Z5T;1$O!@^&#xtN{N%W=kE ze!<)3-ZdFg?uouRTyFpP`-YODX^T*qCL<;Guhg9K+gF@7>OaJM-XY*#of@Y#(68UW z3HVJb`a!0yD{b450H2k1$5X+n{L*xmFtHvx7+@8KYAXv=8yFINP4@_Ickrvv zmgpIYMZeB!b}CL(CP?ht99jbsfHfZ^29-Ri^fWYTL-%3_N`y{$jVmLhfDSQp`{|e9rX_q0-OoII#xp{TpZZ%BTFgAgKiGY z9j>9u5NY}XLN1;p9_wYdDcH>Xu?A%0RvReLQXTqBuYD5>l;HotktM^U*hmpD9 zi`EocI}JUUZ(4J^F%EDPQ)LaqIvrK=0gqkuu!A4 zP3Xgiul#t!OFC(@adGjG^;eu|Q`pT26SZ4j5@ol83vqz}`m%<1O|fLAzT-|YXC>3U zpVrzWscZSGG4|5H<%+UVEfu1r(M+sVJ)bX4Cp8-l<lb++*%!`|RLWGiE)Xlb;EZ#fh1V+e5ICn|_wJ->>K?(!7rU*88-t z3QZj~C~Yt>CUHnr^NXS8IR=lJ^ro9W@O`o43?VJAs4&|pRsWb;trrX{TjNoquM}*v zjiB}Nab{N4GDox@@--q`PfP~?ZLqQRVsCqD=)G(lc+etj#NmAw34fc1pYta#(MF7? zq7q35l|T5C5Dn^JFRAdqx83MF$jDu{2Q=+BxoJ|}NnGY=Biq{sC+{4)o(LQW*irSW zDK6-vAY-`(JMZ45v2jj^u?qIM-#KmHOL8%Js&iIWR;}*%zP6@gkO}yVkJ`)H;?$@! zz=47uRFMF=U`dCTAkSv=(Nimu4RYZxbFY2h*b5jh-g6}}PC32f3_4qNg=$Hcl-etd z*U##c+hxxJ15=6mySmRWmU%)0f18ss2RXXGQu^$sN2fTl=fs^U(gc}ilYj8Lg&RyE z*{5Il=HNe&?E`L8WoPmYvs$ai{4GL;Ut^M!iXvYqVqdHIDK%MQ`qy6-w;lYUO3UOv z_O7NX^?|i>iImn0#$&(7vUzjXRz*@-nHGKWKvuOh$MZ_hilPrv`ebWk9Zbhq%gy)!z^7%lJTvAl1sw&PfH#C~!- z2@lt#FFHFmA^pn8(gEP()8gT25VG>d>2>R@7#4<;a$(1duivh+3|FHsQZi~Hdx5&-`}dZsT3ndFvZD8@Q)}*q-?AhnN2Hycu3ZiD zzVsFdd{ZxtkZ%Amr(t4T(mY#Mc;15JL?DL#{slt({KWnfKgIu52<_6tT+Rj!ih-9@ zJ{#p30L2aGYpoS`RaECfKCh6++!5JyJZv6K%9AWk&!?NXHlO3y?&9E(x^PZt4!=EUylE@E-P#9_xI^D!${ zhJo~!cror>g^!`EIwv10yT&hOcY&(cRu-Z2ngn0Aq3IE?pG#BonkIm-D0cJZ!6Wd`jPqTna>zs)~JQJ1My|QoBhF zLxXq4XKc0>1h!%LXDs4Wp9;C_S!=I84q6aq9JPl=xex(8v7rFSxZe{{fM0f|#G3N3 zicBHDwlJsaxO+NwCFlDbU&`VIYi+uBQwV8%eY4wsmK22=Z9zjrz81!jsWIcd zf~t;cVW#b2o5#X2dXpsA{V?lGYjh}CQZ&tB0qU3M=E+IZZ%o*y-E5jXM_L17Jrrk! z=qph>-D0wC6{kEkm=wC5n{(46$DJzOpQ#_+r6NC6lZ~J~xfz?xMgfV%KJ0xD15M|D zX{R0yiIcEv&_E zVBmwJfaNhiHyoq ziX=jxj2*i>yVXx$X;P0s7LranWff_*m@@!>y?1&%1J!Ad&=Qy>*BhtgsXIVQ1Cx^9 z{4P2xJ7CHyn1Kq~dcx|O?(2S^D-(y<8yo7E*&U_oKx7aIExQq6KUbiHi0+F16HiOs2 z0V2ZpM=W(*ij1rd4A+qv-dl22+i zNVVQ1wY`mmt@8txkd2Dn45#_`L;Ox+CZPn=_J=f`BZ7P??Q8b1xqHPCc-cdoZ{g8!sMrM#l(Q^{+(q z1Mq&NQxOpWdR<c1NjhzPM3a8%7k=e6jI>hiXdJW z!>kK9UE~K{yxIu6NRGJQy-SXTuvpoe2JFy`pY!!kvPex1moFa$EXS?K%E`-*^^Sm( z$&lGW-z_tJZBf<+fSzY~tfy|sia<00_)pE6-yKoz)4pgfUBzEe64j!e!v`SmX7YT| z-6l*&Hr-U518gl75&d%hFA^OA=2gp-w3~YJ0ApGvxR7h6Nk`T{~p(#iNaY^1pPLYo%rs95Ha69 zjo0_J_iOaQ396~QaD<>UA|_&`Y*3G#;>6d;Vx>U2!oQ=1g`LrciDtz>?!YlDgi11X z3UkwAvDc2LcOV+K+n~cNqnu*QA)|^B?|!dB$;LFj?8}lusqrPgt1+ZKRD8Znvffy6;)?z7n<6K>2<9?r zwPTZIgaVQZ)anC2His0Svmh<0Wc>^b2U{jBuoo{|Uge*UCMIcmZd>3&Ccl6QdaCiP zjHXe^7Aae*d*fKCIhbgUc0cVNN>$=3|2D-a|MB^IuG8ObJ{0zl`cl1{kMA4= zSItdc7jMd7lNHb(`4>4FB1_=sj8P~SxuiR z(kjSY$?U4f8qqdHy|bhb3H;6i`J_Dm=WdqH#<4LXePqOLgFcwCFOZ(UJ0=|yrq2YX zC41K8RvIqn<-VJ=3Z4rE5Xt4M4QlV`XiPwWmBV*%Rj_<%FK1psj+W|15{83c^$HO3$1uzVfwPU?)_oBs`TmIV9byKeb)w&jXB-X!W*pVdt$) z)Z=-*x$v*k3w4HWBh)6+ zOeH50Q>GH%->%YK8IkiF?DOzkVW}#q8a$@?tdr+a_o<$Z~DDnM|0sO_j!lXCyTCgSL1hgVM`HTPgvw09s;KKXjsMPmhKr7Kutro2he5DbLy5rpRvHh^Y%Nad2~ zm47UB8a8*2x*_CBY%4;xsI!QWqPQO}d~R>=uZMfd7nc?Dlf`ciJvr`E7Rp)3eddg% zp7t5FZ|`n3vE>(y^nF+uKg^U)u;X8InCD!{u?z(1zw4vGYwqb^yDXc5- zAUW}<&lR!$r&AiLyKARONtN-{tC~q6a%#v$#3Eo}Fkb57!V$St>prpKc|_kvvEAp3Q59fkXYf z{p-YZy0G|0>!1XrOfPU26*u%ku0%E0y94r@8CFq2krVa^Cae^m3kjh6PVuIc_9wf9 zS)0k=Oc6DRvgKwULmKJbIjvbB=0{(AkXV(DMBkq^j;&72^3fuhg45hWwFs^zQerIv zd!&9<*1Gc!Z!F%2*f0Gi^QZ)pr_G`le~bQP5;vjn55rs7be!>iq&{m$EXesRRJrhV zE#Rw30ICoH>I>;Urdg=^p*2ITO=29!R@rV=fcUxMCv-9u942G0jBle zdHq?prqSsjh))**)&bg$1IUHG#n`(BH`WsphAdhMIbwFg2u7EZl=ux@o0E)>_xsJR z8{rX*YA=LxH_%9+H;ayy!sYWzpGWb%VV<#r$AylY;>Ydxhz&${l83HH?%)z?VW=bL z61}xD9?5fUI)PsO@8rPVgkin~gl4^MXLP$SH5V++rx(+&u`1{q+@@GkW8(U_7;U!H zHu0PmX7tRQcSii`G}MOFPNp3wqTH~twM*S3Z#S|aW-{wEbQ@&E_r{Yp_FfvRbOR0R z4*`-3!qnx?I!OkrVY5!h)6;P}QV97=CwLeMTd{m8ae#?)qC`b7n-RUa& zsZBc0kRmz-Zb5cXrQ~pG>`i2`%da}n4&h;m%`Ju~?Qv-pi1sPa;rQ4i$ptvY>Pnw2 z#ow=I);KQw8nxnHX1x7Qgh>oUJ&D%(HM>kI+O@M6-3Ozlt{+^c2qUDtlFQus_>Bc* zt00cxYY4;{3tj{qKMSJHy+q#(ufHas6K%v^A8M0blitA2OCPOwB3-{>(x7KCyIn5r z_Zn~K&V?3-wi$jluu8!o70=Y9G+$wNdc$Wc7!;}QglB`XkV{`p=7Vg<_p-m+;rkSE zxU>Kb!621L58C44trQlm8}e#)Ud!E^I6U`i6CXNFX1##tFhrFMS)DP%W(9kXHqDkP zp%Snz^I9KiC5sTfuWEMI8v$xQZ}oZF+uI+0=2<+^)Z5cbyRqGX{n_nW`~%Tw2Zoxu z0n7c0i{;Df;BSSrk56Yvusb*dXxdMj)O(?Ail2W3Tj&_yTu<_(KPIS!6wp{BYkF~N z^S<-CY$f!EXPkZuAn?|wE((n4zUut*$GQkuu`XPp5b+qeskY4x$bbZ^ zlzzL-)|JbW{`m$Jys|HlQrj=ak=|IbFC`}X zoDE^@uSD*dFMfm!h-4n94|fH#l~$ESAVY)cU)<-*&39l~R!i$eC}{x7ySES*EO?@cO{m`G{Z#&bjnogj`etl#VR$&w-IO;d04j!erMg{TmVg=GBBo@ z6)ojrlePG}x=Vn^WtEQ$_GkhPExH~0t$|v0>JNuJ&=*GDn|)!f>K~)shE#x?p}%iW zB$3q9*kR9Lvi|i}5xb3kdl~nUVdEErvlXH~A@C4ESy)9O>+;(Hq8YLvjO^R-A>DbJ zcaw2T7~A$D`@1)Mj1Mnu*i53f9{5wW=~5?w`lx95gFkcX5-ed*N)6tdLny8R5=A?{ z@zZJh2}#$Ez~+gFkcO0uyyrysiZX(RZ=R3f!{DikffON_h%M1lUkW<{Gv&z-``R;>TS;8PR@_BcbT>5 z+Je~}l(YHYZn3@L`_9DB^W7$Awo{KCp6-I7Zat?fk=D)!99fJ)^GU#?wZ~W+Bj*Rx z#hgy)u%4tABI@T6)Oo+SSyxlV9R-x3ruW0W)=eRir6oTyT@bXp11Y0p^6OuIeB;P& ze&=_m&E4AST#xGw>T?lOE;^6pj{NoJVPD+8HRCH3JPp)l0YOE1L6CF?0Bet4lx+^{ zqdR0EnpwA6|6_9H8s?{T&@D{Q!=y;2)ZE)!!P7a_j3`IeaMrur#|&fCOp*@*-MUX7 z-!$7zs~040nv6MYHhUamrAT~BR50yPtdrVO%rxU8Zni!`cFj4^9xQRc6Upu7D*v=B zPv|T9McB!MlocM{fWqnfkErdBu`wv8K*EhMNq3a?!feIMC;h~(3d1V8j51mk#$JO& zZq$!&9OinDRV_FpfEry3x^lQ!Hwj!RN-k-In~y=KC+_{q3zmh35ft$QVqpErD(nke z1PMyOY-Gy0#HOcU@Ea!7LL>9*x9pWuuDLEt8{V7D^brweWsOZ`@z{fK;;aSzGfKuO zXFM5ocMh_lklOuw%z$*T{&`rW)U2>hG~qRXyZ87-k~Uff{YZsOa$Uq_iqt&UDs%~) zjvs~h-6or;fZ6|_X>u!icRM~8*@xawXI%Vhp(s5+WEAj6X6nR#B%sbzdQ+-%c>!po z_74~a74@nym5~^s!!tGZ61{d23T<1{zMd{sRou^yL;IMPQIim8n5-UWwAj=ac=jJ4 zs}<F!Foxk7-A6VE5dBzs&E218kMNxXc5I!De5PDa!Z+@ws?!oX1Rl z`uJrSp-fLF+?t?Xp!cKCL6cHaOZHup^a4&7sdrs@N_D-IyfBjncYIh!9{D zDdo=nd|A3bho7yJ&QtgbQ&!;qnoyIdgi#msE`IkD9XMXoRg^Do0s|jcw1mvBnx;>@ zps7$fm$_%gJhM?t@Yu86pi1!*zkX0U(Y5Cb=%02-p!ite5;~3rf|iy}-!nxZpY!>8 zCtn?LJACvI+c9Kt=sWp~%>tWo#27w`2Z|A}`Q-%^CilnZwRXjQ91fHDr7@2xQNVmu zfr!sMi%~a!W^EmAKR2Gk)i`B=ZRfOqtpit4)_#G!S|F$C;#)+;Bp>P7II^nst=vPsXMhDBXCNvhrr z^C|utXV;-6LIPTbKq>{SDw&*?voqFX>)`@SaK~_9``nM ziNO4Lwi2amxpsm`sgZ|a46xu5rJDc-{vkjr1SztmYm+4fYt93x+vkx zz|VZHN&B_S{c7F2Uu8TB?^KGTF*kk^$iNAK0LmZua&kxJSsnlJRFYr4KHDKwQdQ&B zUYFtmsVoLN@=9{RjZT{wG+6H;3IBn9WNooM+eg1pTU<#AkAcl3B$qs>?qBHyj;E>= z%?=jn$E<|?h$iGXzZYw@`$PPu?Pn67ct@3YFUSlt8pp3NHqto)Fn`E0O9@5&c|#!N za7MH{uQ0r=zjq6|pfQ7o9*ao9d5)%T>B4H9&IHv-7b#M`%V6FVl_h6<4rhtjUaV~E z#>E$W;GO-bZ6MH10ak{=!9-N(l}}xDD=S4J_k&ypTg{`Gk%YsksX_ndg5Flg#~TGK z+S^9igkhTSK8UVmlwQXzMOZ$~N<^fm%c)gpW693FHH(m1(s&0AunH8sMlKq+P|abP zinTNX+mpw64o`$${I8vDes}F-Uwd19$!_;}eO(c83a51Y{ex^5gTQ zgW8oI%SzfFO;8Tg6%#v1_mURS+@3d0n*bH#N}I7e1o*z(s<$`?u~D&OecWvJ%L#mf zez$8-%=n!WR&5n;vk5=xD-7_}kUEpJs zRyt|2BsKOgK+oBFzvi2JtV9|3;en{Q;PCKGPgJNyckSI#_c=8w5q4C-t@PB*F>b2m zifT?oV(eO^9)SsFp~$)bHQ7i$tnfdAsKr>~NX8(|LU z{&9A*%`L)6tAE&ei8;nh$RD)&_ix%ZMNHq}BVnQR=Bo5K*kspQ+sua}|BE};1zb8@ zAg&mS#glT&F z5IQnlRH+a>_w=#H=KC9jnR65&FK2IoGIAvl%vBQlxelZJj*Y(XDl&;4B~*&VR)}<@m9|*9jF0QTe5|Yy0T}wzvcQ?{V z=fdv0?>Csau9-P!&bja3`R>0etx=a+n^fe%#g8{!OJy`sEZS;0gR$?p&l z7JQ(>LyYu99cFw_ZxfB3jnWeP{ct&u;S@Inc(I*IlJ4lh6*g|FHi(FLwehZ;-(<7V z_#s`D?C6!RR-PQlt z4~mrZK5kduhumnNB5@DlcjR`&qoi#QFcJ+&k9CN+mowR%>u%L-memMDN&wT>%`wSQ zuRlPtA?U%+XvD(!vn@pnJM=^KvvDe7mSpjhu&Sz;6$=c7d^I<}?|@EX`DrFIHJ%e4 zNI_X)*!OH@KEBzi7n2mwTlZ)dq4lAtG)XdpCkbX=MBA4_N9U&UZs4n>`oUh((Or+2 zBzoETkI35*FV5p%*`1qWtQMI0Ht|9NKFljK6j!mcQ$Q^dBn#r65nS})bc zPCf?zk~Q%)mr<+If$!Ji0pArGu zi?vO&xJmvf-(oO=GP3Dv zN8b9sIdMzeyRye@Sbjzr*kZ#1%FmAZ#;@pPt3f|4a_`T!mF|M2_n2Oh|l^a(0=0-({qe^=rgE{ z4W@Wyip@9*_Ed^AAd=4OMrNZQCwL*Nn~QDV!Ft?!zMDZK0?-M2*vez(O~W?RF26e5 zL9Q!a%0OSIPgc7g-GG&<6AilnAwg|Gub9{^H~zTqWiG_0o}oEbBZ%Pq2_gm31K?EvU!T?r<$o~>6(p871sUN@7~D=7}7-q zBi<%KlycfJ%TIE|-}MHc;S{gXi$mB!puZizwAm#A>Igk|DqNSQkol#^N== z)$fmHr~unm#wd=cB(8f_!1e>__77jA#|Hs%&pTzEmzi&}Kab{$_4zJC0-WJVgmGU} z+e`6hKId6ZH1-F-J+Yq{a1Bn&J{+Yy7Jn%HPK>ukP{ww_;x*?*^QTIh3M0r0R_%98 zB9CBz9j=j5CY%a`IcZc)bRYS>d^t)PQMr@5`TL;*{jo+AvqTjft0I{1>r;JnPYGNr zOZ%E(s#t*r7?SrSk?gyVs+wkAQ0Wc@Tx7V#h4a_rLpXny0Caz5swDt^4K-8eHJ?e$ zvjM$Lx5v0LP?~#4ReZQHmUo>=^ftC{EPGm56|usuZDI}?_SNoy@)?eP_82nnET zx=K-y(|L6r@<~q2kzc*K@U`oq&IPvgLxt& zLvviS85gli34PFIIo)KMxS~_~T@M<1G#PjHLQLG#88nj~goLn-rPItTX({?9P7FJf zHbx2r`41TYKYF}pyABC+utK=E)tsmh1#9L@yTi^o&QOIkU6ZJpUfX0==*@kA_&clQ z3=*&`3x_jt^1~9V=YFz|^W}0ShM~EIJA~)=07!e3t1FD`Xrg%LXM;msqn~cNOu@=O zFOp}#4LM=m$Iq;U95D$$iF{hgg%>=Ln;3Mt0{{2!)rO<3C=3aa6rQE?oy1Nixz)ir z@p4nxaQE3;4KtLF`BJEKH|eWOI3y<-ZHOmUnaJFJ2Q|Fm($vEF?RXU!VxwumV;=r! zL5xJvErj?m%hyRRFW$UN7eovoK2vi#{23X@et@X8;^NX6ei6B!r z-=Y}ASpSgV6*xfwIwYei$}nXsMomDs?f(1OH|O?{W_QZdtv{IZ$Z-SyJQGjJMFoKNN^<>N_PJNwgYqxy$Dn{7cJxx*8I6o@L;;_EMizhDV zbXgAdSZ*HmFaSJrf+R3f02I8h6rp3nD>WNdT)gh{m-b7DzE&$mnnn}83%ZC`ubBeN z{_sf7tDDW#5#P%1Nt}*qulzM_(BUmCl#kiO0S4~SUtsVMgq-Byia3qhll*9=_#g4e z4Q=T_yQ4>DlDI-Ef784BzOz4{(A6F8?&*f`P2#;FfBEGx2kz!Q$wHv74Dcza(6&D& zK9x}SC)wqax9OCfh32F`C4Qf7k>MmLN!U|-hqXa&^RTjB?(*82DF1j}*hJ_w$*!aB zE>bcr;EUA1tL?wkuRG9ZVym(b-xl%N&rs6TFAtP2wRaM-Lz7OKbf?)(KK8O?HvAKH zVOgRW4)XZ5AUsXE17%FBPLA|VQ6RuNic^o;;;Gvr`JWU*1l#2vA!EWfLadoj{2*pe zUG<6I%f_k{wEP19A19Q&J(AJe=I)CumOcJ-w2`HV^6DEgEsl-=*yaDD>!s#@lcPfi zsJ_JkHsUsMpI46)0vw3DNrvmo@4W-s3yzgulz^(EJVBygP} z#-%x8)n@XJ@Y0#~v(vne3RDtRL6%(HrG)iRe=cO8dhP{zT9R(pymJj&6M7^br7;5OEKdgR#2~z_J%}6 zndEs}Wb1c%5H#W(>o6h#(wes>h+$LH#)3C1Bl_Ghs)_hD)^Ay}iRs}UDQ&G3swNq4DbUH`5_?-EllH2D@W^327%yg-5^kr{!MsfI!jI6bE z`ScGkAjb}&^RRo8G-#D1={O&zFL!@VXWUHQ!I`OFYqcWG8W!^S%izol ze?WFCQD-ZWn)7J3QAQIqjZKNdT4fq|jI+LW&cXSx{i)As_xpRw+RaaxB~$ZACdLNw zWyZig*DoW-UfCE)vJ1YBer$|efG@pUyx^6|b*Gc5$=klG6(EaDP%4+JzAx{y7%OtcwXX6hp!WMZ%=r)K~i&bT^^4$wM*BuV_s`}%DApGO||{E zV46g~>3lqZ^#vP|Ad~5KatXi1ixQ=^yR0q0Q2%kP5GV~??{rawU+zy3d<=U65IWmc zP?=pKWCd3*dAg`a_p|&1q$JVmQXZnDjB>-X>e-)nvZn*fLUj=r6w50)ZFk~Sdv}Q5 z0yXwXVb~@{27D`bmmaXi{g$E(N8Zpl&Ns7#H7y|dT-%UO1%RnapRE$Jr%Edg{1iy1 zu=TaI8W?FbKW2H?6Zax@VDLU=z?fSmWgCYovx9PAvY!vcJzm%X$81zP+(@D6}jppk5u z3cD1tP-M;eU6ePJeca^aGQ2F%l;3M9YvQR8Zh>7EA?)@PFZ17WsTv9ya7l;06b2zw zbv*jQH+QK&7gQnq=LR$D_&ppb)xtOV8woFuXbHY1{_uFTu;^|Oxft#ew|~v%;$ZU7 z@TcG}qGzF6GJ8YTg!u8Q@1tN2>ubC%G&*D6kH-w=Y<*eMBwBm>3)bg;N6C5Zdhe%)FX&+{qX za$w^)tN36v<}oK1%+r&T3^d&)+IPDfy;8_Jsv@6HOAIP%_6R+HK+;uJUbSYCNu?P4 z>{LNXGA&GLpq0~#ozpXfi`VUOGLzWQOe3bISB7!oC zwu_Lke6*1Kmk5n%WVn4}6s+hUT_U2ofE##QE_^F%2;UJf<==O|Ja~bH-4GK4ekju< z5-6T2ae89CFwYY*Jf|nz+`dQI(Jl_x2Adu!H?-lhta1VVTFsvIBp|5Z-742BYQ#2< z83-CV3~;yI@J~#Bp<)KZnz38>wL!s*Sc7UnB{0X??z$yBBB1w2J7C>|riYZXM;Q-K zyUtDGe@IhZdeSFQMRegaUH{LZAn5KvrpQ_}BnwV9?OdffZIs8vAAc!;VjP zV&3C97L9Xr-v2*O0c}f^gSciUx~DI-)WQaNIf-^Qzj;mamX`@HmW#oD{0e>f_LU(8 z1Mc@|ImRDL=EXL+fqg8=%eNkxT6~4+K%myhBEh2*Jqj5ued83os|`1_)~MJqO2sAs zlb}#j<2B$jPasGWtMnVOeu+vB{PiuTD$vre!c*gOxT~l6c?M3B;2&p} ziKu@e3H*}GJxR_#<`$jQ4(6&8_W(dl`}y`8yxW_xBN8(J$ZRPgod{Hk)Bo5XS>!4W zB&lQ16o5z;Y@h1k`?31Gy`3_mf&`*+vCUgQU{CO*Pz@^ck$hVAPW89^PYL{9M1GA6 zgP{5!&&HT%7SGZijB-B`>yo}@KGuuOZz#fCn$EA{FkAi*Iug7J6~y0a*r;0nu_APF zSDL!0be~81mc>w-c_Q(z*wTZ#e@aREw#lc3JJz#rTC9$e2mB*DUrsqCYF4?M)GB1X z6#uA92smZjk3<8<{=oZTSZ%8G$CpI$RKPWgTH8A3b;av`$8Q_tqNDd7CUO z3KAA*)jnkBJcC;pAt`=0&iVzYDLd3d11(1sQOuTb)yZ*zWgLAu&k#z@)l<@ zW4x`hIf*K5ApSGMYSXP{B=Fy&Q@$$9}s827Eg7q0-quRsM~rz-_o5-6j9@g<5t z0A5_+082&GCvy^`3Tye>w)jISwI6oi7Or&@lbVVfJ7K-HAC4bStSP zlB-#GE|*RS`wTInq? z>cECQxh}XLa7=#~Os}%te+5 zK=lh$a@U2Z(#>c8S4UfhqiQP2Iw{i}e3CDsBfVqnGULM#mufl)N59y<3{~1x5rW_1 zk8vu^8&VdQ`F|82a_PDaSU8=#8|lBWBZwko`ZxBn59<{YuOJqPH}rPU^t@*ta{4pd zmP#^gjQ11rLGYjxPkP{7=0k)}0*l)Q}zA_CsForvkAXcX-@ByB-zT1Up`3@k&aS zQRu6n_0r|j;jZdoCiYu~p1Ub+L0Hhj=$toGtk*7HkqUb1{R|V2IqF$&*wo;MEC^xm zw|?h#ikz?lD><>=Y18BbHOeL)=D_Eiv{sgu`Tv&v^_1>aK5FdT6RgtWo}>km0^A>T zM+5XZ2~|UVIRMNDU=(f zL<5D#GfIN_GKGrE?S}m_ydE~==4zz9weE(WAfwbGBxF9F^WXM2@g} zhaq4`w9Q*OeI8r%;-Y125f2nJj5#f~DBSlK-pi6Q`C285Dx6mrk5NVdF==UOP4|$;s*3#vwqxG0fd;V{zgPZ)MS@ECzYAW0<2yF@wYMoAZ^7ozwE9Q7e9AY{$ZXhn7gA$SiBM6V6^vQi;k9IBija(C^ zBrLu^D8ANwQRppbqgVV2<0_l=al&v+OX=5@ASXFZ{Sw7^L&y)AG5bMERSkr?5{~L} z^)_KI!RnSfZYOG$n2mI22G~@>LF$;<+CI6v@8{YlK8u=)!ZBF!LUjcwLKWgN8(GJ>VFAT&J0RzuO0 z(x1NacjA^@@J^M-^elqO+t!fQCjH^;qZuRCM*dV#Z%TPVmw=f#55F&~G;$@m<>~FB zM(f>ZknBT#WA!NHxWwzo@$qM|mj@C|!W6K#gdA32mugUg8_@<%0R^xH0aQuBznX%BgAZB=?DAj#E`UlYXHYRERFjD< zc&l@Nqn0x3F0pIqiu;}h+4eyzSDBg;etV9mB_T+Md;J}7qJi0oHZNSU5R%NCQ~=YD}G(r|LqA*d6|h zateF{iMUORPagmdKk<+{%8w2vy&5-^Y!{gOhaZ@m2|TE((18Ol+@OU=$-F=W*@+taMZ zEY=*2TT&+bcJQ{7t6Gl#*=xy)u1Z&tSpx#Qhbh)8fUS>KbLt7rfUvubXvGMnrQbrYQHk%gkT-_FVrQuq?#SaBZ z(%&kBtDm#2bp)(FAxoVIR}-A?$lj@P{7ol}F;(S-)o`pi$RFq)w7E#;9KH&EC39Xc zDRuFVwn>>O(0YmA0(DXRfiq6O3xJtf=)mm-ofIIkZv}v`)=H62s(_&7=?9B9R#v0$ zp+}}c6F+pIkO?5k5*Oj8s->1g=T>#ZSNqhS=iFg)9-MpHsuF1(%$a_Z!_6IakrRp9RY%Sbb!aBuVZ;($jm1iNN?l2SoMuaK}f? zjkXIwFXyy)a(Osk`%!X9$9}6PG&BwI>9ssPU1la&hsXRLtlRfTEBySc@H|Ck!%FEE zLqe`06LHFv0)Tjoe1-YcGPdHCkf3<7kHhxN_??A(&nuZbTw_uAEoZ6822~ik#yPt1 zN_-8ft@!{OUsv-jop8e~Rjp zGK-R;79y{3=*2t_ZtpG+oxQT~k^4oAN;t{RbF{nXD16w)ub=FNsAr-=xO1`xHuie3t$ z@iDdsN(zsF5QXtgckEmA1lv&;TaXC#TxVfSFr!CvSYGR7)4XdkWD4A$x6Zg8Xc3rC zlL`lPIQzgKvR#}&go1H_^u$b*Q8~I$;12FP1EPPCe7|xTyG+6c0&|3LGUt3LD6pQ9 z3Vj{jemLA&I8ze-S9-rN74LU-Vs$#VSr*Z_uK*EWOia2%?4hM6W(8$s<>l#VEH5BL-plWA@PiqQ4j-g7!~qr1#a4YJZ13L7mPkEhx=c)>`q|5!0YE2 zLn&aoI6AkXroX?-E9gqo&^{RNM;85+Lq=XLn`RV`JGv#0pE9IY29a!;q zl=gCr-?tG^3_BpLBBb3yen?zT@=gvN-P4yH_)OxP@kQf_Q5wkESmeQ{qT!7{dhvw+&K~llPVl=7tELz1%Xu%L8Ku{lc7pG7X)j2(yKOj4r zno+t4I2cl?rdcR_9nC?=CS9bGR85 zviL~O%(G_as<46SIP3_n1}NWOux7paggkWblw$RB+1Y=rP8+oN4$*$Ms|`;Q47l5` ztgJNiXt=wpo8)LT@OKOSFJ-!Ih#!6*D zxjipKV_fcQ&7{5F7c-m0UfeUCW4u@|^0FD7eE)&^ujrjH_RS@2WmD?5)q@4GKI>F4 zuc>dDjKVd{Bb+20QtjE~hh7fQaUzTQSAE7FR#hUw&FPD=L))K!*}tMdTtrgrKYw1W zOU}eiX^E~Rsi0vvCZzQPvBg+$cPI)IleE;?j7?`um;L5OoPWr?IomdUhOH_5B|14V z^YXcS+`;Q7e}xA(gn(%Z(5c5~XhcV7FqDt)LCesPi`k!&Jdx?GkYNo1Wt-bA*j=rG z!kve~gjxrm{97z7%PX+RjK0>@@hvY0NUwdtVkh50+#YyA`64yK6sy zCLp0e4DiI)+SogI*rQq9KBi-VoL)^!AmzaQLGWQ3q!Dn_v9?sW6ERQ#+u_ZfnhR}B3c1{=NXCaZp6v<6?fRoSdkfCgNe4@3M(!1V z$_aSx)wZ8|?b3-b3NE8?xedn)3A$b;SO!ip%ba~98#`LTU$q-1mgG9toE}x0FeRKO zW6|+B>}5Td`j|&$XTSeK@lz0%AO0TVg@X_IQaiGr$KkRy$k6cja^Z#v;rQVrUVGfa z*$U>?;AXY6(?J-+%%7#%OO5Co-f#%O!wr$+U`}fJq3{N-fv*srdHT(3wQ)Pco_l;Z zE_}D|%M?)-Y<`cVH*G-k+wU^0xBc}QfC9Lc%%7#|Tf_en^&8jHnY=LaXV38gjkas+ zxw_-lsf>Sn*CYh?r808{OPG~`1$Km)yz+#bSP+gO(I>Z#o<-x-fmf1J=%Y)TgNEH( zYPuzlZN%v*v0(CO3zgP7nD8GlFUwedOyi3=uhBO0X0Jmx>Fb^B$iCOC;Gg&hBmrFE zaM_E=x>s1ZRF^?8oE6=r3IPmgOWqLc28HSeZjR7fe68VqTRau?{+{!CXIjecb42d9 z=kCK1F1cfb_g>Dp+jYif_ulNYq7LBg@9U!#G~NX-wL?Sf-1tML*9FI$uV*3!@GU`Ku6|t) zWMEocw!Si)owP+#w(;)a!8)wi#>$Wd^G`VlVWSVtt|huU%tmp{{yTnbAbj948!JQ= zGp<(Jaoci+PoJ+vo|<}#Us1Y3IQ{MCF5hb|J^%kM{)l^nyD_(h5v|95758TWdk|{H zg5~D=dyVST97LT2bK;b8$a5UQd{zQipBts0Ha(v8l(KHFO`5bk2To3*)(77sV|+Tm zDE?gozG{YVLPEcP&nD>`-qTHkRViUHha(-9*894&tv6Qv_3DYgaE{?0&gk?*Ajtcx zW#6Nm&(x-!I+?w_k`G#zR|yfA;J9t?T2`9CJ-NbN*!9{e0XZUmlIC{JzDJ|7-M&a< zaId?{O!A>ihhkN^6a_1rQpIOGf=lLRWUtqYN31LapL0z8$hljx?24a>1T*7<*X(Cp z-J;N2H;1Rjoyj0(G8!kbqvT$fcfkoUuo0G_r3CSknPe*`lb@5LX1~Z`t^-GiLyAXS zW-!0p19*8NsJ`n@7+?zbUzpE;n`oq?qa4sFmk{vv#*&w*sQKNsb6jj(;K`H6e$TRS zA@PJ9901`t#x<@Z8GSHH@Ubskbv zq%n|py;=&V=Z{9Oz89o)X|$`*>2fjAmW}=}(**~P5oi$Fh4*BB{{=e4*QjCJYaaEq zE|FP_=V#<_w0(hxZov~)2Hm}{Z~xHo-L>_9fjUf*$3A1O+-*k`man%4cOxy49U_3Az%cBJ)%HS;zC?62dk*fD z7_1C9wQi8p1n`3ARYfs+4-44~O#J>eDk^^Yg8%x$l4^uPR`EF7!*X`%V4I>04 zKEXhm%uW8HkrA#t>BeLvmXIt@jrf~BlHpciBjA>BlUPB?zoroHXJ5wDHMI3 z=8xwY$G~+C%MRXmh50dnEZc(9T^!m!S9TN!e!q{&)BdS!+%KCuDoclUeZ}}Im1uQ@ z3itNY>Z&{>1EO+Z&!wlCWR7YmTo$jUeh$9a{)%Wb^;<0R7m{^C&2+_<7e*=v{tH`} zV?D?A1zRp!4qU%p$q{|wxLIQ#`^7#8=v_Pvkez(^Yo8Sc5oj^m?kZErAAfPeYvCh~teL@*xDp{BQyyWhS*Ycmja%V)7 zWSq^#RVW1EekXTcIkFFWI-NJ`aJ*&Yd}vhZ_E-`~j6D<%kpTZbI%?SXQy9kuPfOJZ zQBphb(2_}f3?OuX4?t{c_n`A}9Xh$iEnV%c|dY#uj($B}~)>dzIA&;Bg^ zo}k;*|3&fT?;t2IX)O2>uN#dZoT(Z?wtAFqqGEVS;ogiihdOE7VmN)3dj6+2+vX0i zpxjQ!z}|I4lfG}q{>~JxB$cJMtgg`3`rOQ#df&pte=_%AaH zdz%9OHDbwNOvsmY2_K3Rmf7irB29dUViSL=hni-^>W<_RLSf)6TqHW1v-hDi?me)% zE+B`~Y-MUbzgxkXW*-rnqh+TXD0E*kW8yT`mM&w2yqQA9mJ?A2b>@<@*U*^~qr%leN!t%PT{o_dWlIyN&>;Rzxyc>d%N&Ei+!vF zqIZU}Km9j<&ElIFs7b&s?36c^; zC``Du2`g$cxJ}Tc9?Q&02@vU*IEWD%o z{Pi*I5eb}$BQWFg$_~tokYTVDNxW+iZf%?+otpBHXRJ%T9g##mQdf&BBySUhq6slcs=@#> zx8k_RV?t;*0n!J3{}BiA7{{IeeVoo90V2EC{4AlpOu%*SHK)67I8-U81nF|@fMG~o zd6|zQ&IZZ;OpwIM{S&-<^Q~L`RF6k+?+fFq;2_f62#D!NF^I=P4+bl37?uneMZdEJ8re z(hY{D+L}JNb@J|RL+=%D1$cXBKCVDSVSFfo!ez>azpzoadwm2({_;h^sXcoP%mM|dCi>oUD@+h^Wkj1pZY=5@WqIcD< zY>Gr`0GFg)kVu~U?xm%fPM{nW(vr~XgO$!}L|ff8*3oxRUF*&0X!wdN1yo3J$DpUS zX20#K*N{`bI%z=W4r;Ywj#~2f{X1#2Wof?a{F*vlCF`D*9-k@# z_gcXLgN^aLjC(~Lnv)nT7Cecz?et5@z4jH!728qcei=Mf%%Z1DvXs_c$QA9q(GfF1 zh${!WrVbKc!zN6nSoEpH^VM0RS+6N)4XMNFoX_2)syjhHreZTG8RWMg$j!x$WF+7| z*(Qryj`kDV@Yfy&8hC>t6kBuU+B1cFs?R1ntS)(b2Pk< zWUg9N1`!Wm>CaFnyrC2|8lg)Ef|vq{f1!&rO#|SDOq;cDGtE!&F13H|lg)B))W)TR zK&iHuaBV5>bN@K~?jEn_4gN~cLVbZ{F( zZ;^u7t(?oUL5R%e90m3JY#foSi() zWd|oQN3;UA)R0q?-UWd_oRsFF(7Lm{xG*UgNrgawiD!46-QJ7Lp7y6#BK!78&4^(G zf6n!l%7kgyL|wMt)14QnQP^? zGlewbX74S}7oi=iM*m-Iz=c2jZo^O>wk7w&uSVl|v@iIfdAb0C8 zXEIK&XqAF=C|DI&vIlo(8~xLRn>%iH-|x~9t?m8ujV*whGqrvtkd_M|(@1K;XNh_~ zYqaVjKtx#Kd{D5bzU=+H%gGBnl&WGbf}}MGF#Ltio;TI^Bwi%N$p}Du|F+J6M-|Ii zc^wiMdP2VyxE~m84>ddP#XpH0BZaACayo1=mgDt7U@^~QS~am9%&#S+)7BN%tR=1J zym`Z(1kb2p!Z58Jdft$LN!7laO&Og6qpe`rb6^N0u^PdDVdJUPXpQnQi|9cpXcrSm z4NS^A{{4$rB}*bIBkne#d(>g<5DyJf8&wB)j0T_@MMT8J^4i)c4@8H#dPk0qZ|9W& ztB=oxr>1l-Fe~M)b(Y&@#;k!#H|6wWCf-CNawrG2wM_Y4p0BRGJt~WA*iS$ec&uZ# z-qf^CVe|!mk$U-AtDak*tCL0vn^EcRc??vG^d)?+lJ+q8{_+qLpdq?X9vMJde=p%M zf*yv6%Y_Kah_7Fj7UGJHacsPVi49>Yc5}e=hw~{&~Vkp7@nxcI{n!n9HI(8z|x3({Ua|=ux>Z4y-x`e zTtsR$UeKcZF{F_x#o%Y^RhdBcCavK5B1XR<%~eOy;POHuzpYgb=@$;97na0Ph4>B+1#AT>fSujgv~~ucj9)6wLklAQ>X|HKOR%bRd2h&|A-N~*@lL^!ce{vC~I%~ z*F?gfDq{ZvzcFc)bX0k4?ngP^s$$?N2QW!AD<(ka?!)Xzx7E67c=WWFqM7UAdk+TV zOuS5@(d}Ri!hA6);>d$pid++O&yB=p|j zz>!97Ff`xh*%Z1W(vumT3o^j8{CZS%E2j97y1e$pwp|uJp>1+)6nh(4z%8fwX%^3Z zrnI`H#)ZuX<9e||{0tlBYeIl{jF|KCN(Ak(cCZOW*z6~_du1ovzvYB9F+d&8Yhsmf z*LuS=d^fj`yLT|AKWokBj4Mxj$)$!xx*3}kNMJi(!eA>SvLCETs2a4=gSJN65L*I? zzy!y{nSc)9+pq%X6p1kZ+y18V}fb zUfq;+7T^qZ%RlpdnNOgCy8*(Mx%##kp#ipe2%rA^xwm)-a+>O7leXn_CS2d+l4OgerKa{yzJexW%d<_o;Gd;{u z#g+1_(mEcEf%ynxKTv3Z5CXczhMIGBLqymQVY{tmFiE|msP^c?jVehAfy~kf=2)B) zc2s}cKM7sXGO@f6Wu586c%mYv8);m9=+>jD3pZdM@>A@je^8J)xO5^nZCbT}FQCog`}nfe7T!}Tzg=VC=` zU-=#bzwxTAG+SojxrnHcI|xQi&?_f^O5VE# zzLaoK+ur$>_Droo=DQ##>wA2)YY3B*i!(nF6|O$Uy$P>1diKhsD(H1WIw3`kg$A=G z=};1ATp)Hu*%v!VvGFl19GZgTh8$Lyj{V|^V!@8_yKR|!XyAL{>bj@=ntFB1^oC9F znmRPm8ASW-P=Eu`6DBDrCMK`%A;SCV?&Qec&Q9<=yms*~B=k1g=G%Xceml-0&UnPg^vAX%tAY>O)cXkiQKt3FZw*LiOtZT$BMwy>Kn`# z>e>kvyrg)O&+rJ)@HV?J*b&Z57VgUcA5=>OO8iH%oRUXw%=aCLAeeK$_2RL_zuo~D< zR@I&GlJnHwRNf5Ma8xK~gBo~)R?8BJ&AGntm>FtxnJ$TTaYC>>$6*)83GIwNz9QLF zLs0v%F>vH@C>km=`VSkJQsgBkO1268bl*4^`rHw7b?If-H?rWW#9T0f4 z{wlLp-L}($gf{*wy(lm9K3In&0{^9x2Z_@|S`7e=`YiDf`07_FFbGS*BS1$gIq? zrfS#vN(sVngm}5}9Gr?;t>yQNsME+@`1~}c*=Aen&r9r|ym|J??Ec2|UJTC>wfBdy zg7_o))hym+o6Fy5C7^SL+4G_BKej>Y%j zIOf+c;Ysk<%I_0KzdNG|IS49kyLi5H#w>{uP{mTc4PUL?a5??6|FeFM??h&dEh6Hx z2&9xVQ}^srtmmkiboTrKb+GVwUc%PAcP5i$lYY3BXbJAfp7UeV>^6jReTK+yg-tql zirFTuLQ#5sO-)Um*Tzr(+$7T8{gA}i6%UW@wPQzlNTE;8C+M$wQ!pYB%N^~AItb#n zr|}~zHWitsF2LI%Rn{pAss*0B*=R-I`3CLb#<#G-c4xpfjAWY>EUL`GG$XB~ro1Na z5`O7gU(VP_l?J=`0`2y0c77ETdb4wlBy0}?kKx@1??#uWzeK4KCQ`pEmj=m3x~utY z)McAVxq7-&K9fOL*mh4DaAvvuNSDTA5o5QxJdC43|0qLig{S>L;F^XMW2Q?RPP6Z$ zjp2r=R&#H5)x4={5p0S(4W_L^{6&>7#`9oM%_J&NPj{n}0zH+|YhY!Y)AZfP-(<&I zC+u65w@D4cwN1XlkZ<4~dYPrB$9;R{Y45l*SnitTf}S~>6_YbNZ2?0h*G>i`(X;n1 z(gOMBJyqp#uij#xV1OF_squm2J$R#?ZEwnSR*;4o?)M=>#`m(u`$DBg-}5b>+14P} z`}boMus56B(mms^K$JwsXb>Li6Ef2;;@d__EQ=iIuYrm4vd#0}ZwG97h|Rr~A&98V zr%|2J!5ja5a*Y~bJ2E=f`>v623LSPE){^jvOAI3L&l zB3yV_S=9EZn+B=*7z#?^FZmz>O4Sr>C_tpKBd)Rc`J`{9xR3G~0c3pl-z!k?EA0b} zQ`7B79r{|~M^FOnSEE|L_p;<2crb4&wp@ZoBLtV+^J2zXWHFL9g#b$o3@^frty>5O z>uX(m<4$7wdbd|1apaC^9Wij(GmW1Ha3x>WZ$AH0B`8dgwxAsXoq|VnWyh32NQD`9 z2=2A=qfMD4uTf{1+z;_SwJ={a@lok@S)I=RsCx^rs+zTLd{Y7{qF{r9lnRO{qGHep zDy1M`Q7TdbB8t+DL5YIWAV_zYv~-trNOx`6o1Fj5=3qY0InR5(_xrBvzpiVTy*6vj z{hNF4nYnB26)9a_IDNn49qG`BKaF&bu#uQpFgdenrPE0!jFRR-9<~j~Kg#v{S-u^V zjP_qGyK?wYcj%S!T#@S*{>qKGx;B9i)p|RV;s*Wq71!RVu&nx$+G%dm)%38fHEWT% zb@Y|Q!mR&llJ0WaBVo-i{%7|R%Pe}^O?C5-#81guU?l0}b1j!m#V_~FY=Lf(N8@@I z{5|&1IyTYGy}WI8)riD+rFN-{w&v<^9tBQevNn+UTCP5$J(&rORB_Qs$(968BD)rm z7*WGzGC2!>#<5-O%T|L-Z!z+l;Nv4*uY0q*6ti}dF^sNQSf7eoeKGI0YtCKa_HkUk zCwJEsN$KLt+h;5cFU;X%1jo$g<0-dj zUm0%Tddh8qG0zEpcgBK7&WN0i_3*|-!F>lM6(3%rp7-P1GGV0bVP4r|Kcbg9_raC1 zb!EZ(YsBV9kJudwh{)#|XwKl%6mtY<1xVXgYZX>hoBZ4QEi=6KD&kwU>0V#C%oUTd zx!JAj6px}tH5qr0U*_cMYC9z@+u>R%g@~ZDSv7lhr`=B`ak|K=xkaTpUcY(k2z9{0 z>DR1r6SZWGy8fqwazacNNU$6B6&B4oHZtS|7u$TU-B>DXUt${A6iUu~Tk)_W^BoG? zdOQ05hc|1^k{wEkFzQO`cci;3k_k!zY2w-*M%|q3&01~ltsbOe!eqo!e>7N~o;tCg zi*~m3%4*dNgL&A>P_IjTE48X^ zYw3!?7cU@7c#Z zEQGCQC}R;}?^lhzQdFWv1X-(|5=&lf`6I=M*MY)Sn1s}o2aHs-IvSqwAk{ix%5Lm5~EFxL2GnGX0G@ZzfNKE!1?i7(AD1_b$YkH%rRRMbvk ztZ&DIM?s;w9xHi=Ck=R?+40;wcf)po#^h8{04B< z^Q3D0PDU0ozGDJ5r58sqltWL>?&i}Xz45SR_c=F#*~Z88UGLrVWqg%fdcR}@zh}I$ z(kl|l&vX4nfasikuz60VN}wTH8Qt zMD_568^jaTN^eXnuj|=oxSQO1R_H8t!zcdvOm$@MOZJUJ*tVPp{AXS^m9{QeH7SV? zU{x1Nxud9G=$F(&|qBs@!$k0DH*eI$UzRInM_A)@)0#DwfC?rM6Jy zdm|vpd6@;n`)v~snYDsMptPk@J3DrhhG0RoaoE6J`)>FK%;m^vy)MBp&vVrodAhY* zYDajEw~HrKiCiqcN$Lz4Njt^KGfqCr{gHy-QmR z+R6B}UGDL$sm%P_QI6dkL==6b!HpCJfw_czxr!OmQUXplAMX47#P@1={oyz>TxW*~ z5%=oy(a*feU6Pa+o+bBw(v)k%xv11^zZLxN|( zzSxh>Zkrmr1#K=aKdtg{A|c;$vgVE4M9E>7{Jwx(%I#XDX%X>MqHicpvQvefJVL4B zR#Wq)V0qUWH-TXvZ}0hYI*-V1eoo*Pb3AZWGifiAB4Q zVtGUVLB~pm4^}taVv|o@_;4eK_`J49S+-J+eN+t3!>9VGoAzSp?Ks{?%-y)5wcTJd z&hv%G;UwH17Z-}iV*Zwc&5m|qLgx8j_w4dMap&5#Z_g)`!A;%77I`8%+%dbS`pcBH zZ#D%@CzNw~Ta=EqNFOZx@`kpL#DPO`x9#DAZ-dXd1;_9ouM%awIDVYslI82|0ihST zxoPb;Z?cVbCB3Yh7T#l9{^q1Wq^#j}g`SDc=imErN%C^hxSEGA>u(?TrM6-^y6K}` zYS#Al$!rm*+^H0+jM2C6s}Z-&0Y*T!sDGfYBBj9LRbWPh*Y&0J8|Dob!qAi6>f1H4 z>rUd)ZRYUt`%I40o|THDIgi2WO4#DvvSX(fb#PwO&McVoPs1|Qa;corJ zgGVBK@7wMuB`UDqE3q=CO`>&~^rWo544>q#fva;9v`HQl;4=!iRx3Q93G(O99 zP~cd7xFU}hQ`j+oy2eMQ^4w`%#(pWA-kRG`YneAw`NfPm$SXpWoy2okx!z& z5LoO_J^g%l17`Q$P#hPLva?(;n-)Jc&Ff;(>tF}}s^ZdgsQTkGm2vM>^f(z6?2ER$koh9oHE z4e4G=%6A#QmsXN*-j8LgIiVrjd*DeE#qh3D7;D)jY8=-_7K2-*%HFu}=)nL<=x|e` z2F5=KB!I)Ti~Y6k40Zq?PrJI`eDlNpN*Nda0 z6))J4S{?^m_JlX=$v)nDKWDLV*>lhrXQ*{~Bb9fvZyo!CFcMKEnH!RFnT1nwh+JK*Zl@f4=S4iLo4wEhUwyt>rov@OccFJ;D%(+? z-F@p`Cy%omhDTzz1aIl3zAB?gv0yVpQq0UEV_r~Md2ZjSag}H(y)o+{0cpEz>5VMX z?pLT!Sx#ghWUaR`o8#$Tow+l0y%e`vFyEcbF>jbYq8yGX=Z(xhJ;YtFxpDO6-GlIb zoV)KNg%wm6Hpas_R{$g2xMq^lc+goy1#g()cG_B_Oj@#<5I zOk`B2Oi1jJ4QTxG<>O?)TPY!z4e8hNL&&SMH^|Ydllo1$b{W<0or(fiPqh~pB!%xD z3)RlVj=HlJ@<=MBo)8RFrS*5F?K#G0@XoibcoUx`$&_VnAz}pI=-?qv+EJs;4X1}ycGsD*D0{csh*TNeD z`acp4(a9`$J0A+v7}~n~%$cpRMfVQ0@jPzt@;$4$Kdh0p*T-t&hIspDm5OTH!bc~D z^C(LLd~+-#;wx6ibC=X{@|)bDBOkTNZw!!ew(>@cgDFFrp! z5Jugw!Ek#Z_2K8>yJ{XF50~HBlk{5->U3mLNrVX4Ge}PNZ%Q=nWbD!7&~S?SD#=VadP;}O z3|}iYG_Jf!$0BD->XHrrm9GL{j~&y)@_fCW7!?-hniBXVZO=!gH!{C$`g4OY`L-WXA=!RaREUJzv=wcUH&hqVMieoHs_|TmmiUX-j=le#)ZDTxo8w(Sl(RtIZ!!?;<&W_<~vM zZ0FLX-jQR+inGl%aJ`56rCe;D_BT3Noa_0xi4)(8)vVutMfyt6MVF42MOw~&=Ba8r znW?=*SBSIT#;J%CZQjRsGVF5IQa{ZZ5eaJpm--KpO?#<6FAyIP_q$E8m>sU#Wn;r1 zpVDOz?6ZYroL!E6$AG!s=a@3DlU7X+f)Xcdtb}E5-xjjt3wuj_5Wn1A^^~mlUcIlj zcF$XB{*LD`sc^gb?S zfmsuyf|Z@*PLh&SEf4(nHK%KTy{U3{#XAuGSeKfi1IOOE_=>LEMjhYaCZnWta zaD7JtgXKX?x|(Ca@q6uCuaO;PQR7b2$CqF|>klw<7v#7UtCRGP>J?iIEqU z!fynU52amah)b&$tR|12i_ZpF7Y>DwWiDIzqb6gmr3@Ee*4~M^zjsgCbP*l@Zf>oH zd$(WK${D71CovMeXnRTKeq&?)X`zP#U+gFrX!@3yiMXCFHw$EAl#Ynd#jOq>z-4^S zq=Odc=7tR!qV=_$_MF_?uq~x>-FJ8--;rkQ)fhd!eFu;9;*c+k-J8mrg8JbW|kE7mSkn?OFp#b{PKb%7`0uNr(~)FfCY zK^yPm&OPVUD_HhjFQ%mAssZPd=w zH6oQaiC9{)Hk{b9%{~-ptW~ZE>tE^Xtq6IfKe37P*D5ZdCOQnYZ!VI;Jxk=f>NN+TqV9@Y7wBah2Tn z*cNmCs;QhGhUva0wi;h0@1Vm?gu7fn zBrDsXm27`b>eyLws?EJq&U@}N;Hv0EI;c;oL`OtfOVXvtc(=t)8CloNPNnJh<7AR8 zCbP{vj%6{z?Ch8`b}FqZ^D-R%^xm8+IF9Rzm|}<6yN7HN9s4Iq zD0B>FDYC4Wbj(jnWAe?O7c)-M?LKpep=ytrbIuYMacJ&|(NjXb)}c|E?B&tn?ALF8 zy!L5mj@s~u*JsD_6NWFIHkaViN#aL%<<-ltYNt5<19Pcd_5L6YE>9njKCz{Nll3Bo6e864ziw_N#3#Vjv zPk2w!x=T{2Nb}N_MCa!wSF_^da`{bZE-jbzsKLAqh1|eFqdB7JWb#_;nu&br)tK^1 z%A9gCn2nxlI^C!MJ^pXRb`Du9TAVQ)+W_rSS>-pqTff?PF7c|@3-6>jJrXLm2vWKRzH zdQyXKWRFXSS(SM4(0f0ZuY>nw<%_#0&dvB7jLBJaziuH0VCwyDGp+g6M;aaMt=*k!E~j^12bPMkPlJwv_~z7j@Y3I3!W7`XN1 zy6$@>*`Q0#*AMOZe8a9TZZT`(W^$32N%7GLtJKQZv}bWsr}OUljo&g7diZc3>2@>Y zU8W~OPoCiqUZKFy*__c)U%YkqTx{j7lz^$bVbludhKu`1PUYm>+Q@%_;m!)tP0U`V zti>`8U{+P~X0Z5?yXi)E=j6s97EE{uvyhNVVjljT44VkuRvN)>mV|rT=x8_5R{N5g zJ$`I$Mk>zUM?C$ob3@~?9QC7o&uYFA`5(XX$$7MKqvG(H-bbfLi=6J;gK_CcMLoie z8)H-)6z0myt8xdNZsn>a$Jv}B)xGc(??I8@6-q*p+xy6>Lp|_-=;O!SQC)F8*s{jR z?+&>J>TWNcf#!0B&zJn0K{eM51d`USMo@S=TV+hT7C^ ziBn>m+N-;q&FHSPU7uyIQ#_YiAJ?HHM}ldsn{y772#1A}O(rn(6n;ykyP_R&TT5nl zJx`&C%(6iVrds1u@k6T$38Php$)*P@BWle4>BauHQp>5neEDKX5!$G=sc&@CPPv>Z zhpTgK-k5eya*kzEDmL09%Gt}g6BkTmrcyE9L-j}9Og{=rGh;~I1pLEgL)v*C<=bX* zbDs#~7I^t7^Q;X&HRE35?ouY#UAZyrrnBUMr*gf?)E+XP8SK~?D&TPh>LizD2Uh*Ewgt8V<8R$+9wSPCQz^HFK)rxNc;K3RgX7jhwsj zRY_Bhg+)I{tUI%5+uZ6@AhSMxN|nMZW)n^NA`NqY%hDT40Y?prJS|OPm)Gv&ugWf0 z=(%h)H|EP&BuS!4vedxGseawYr0Dwo{d-F%zPL28(9?Ar z0(&Sdb0~;=i%GJH0!OO#-zt5P5}KwAt`=|Dhbi#z`lfw6{y3Lv9qG{5ScW00MOR#1 z?`a+zy}|uqV2ZY_l!`9e$x$p&_R!{Vt>iZvU5>}7R}lzuvw_D3~pq6_abndG*|f9g(+O^=J=a?^G2s@ zr1%a>`RE_Hm2Eoe`D){le$k#TqC2;n>-S>ihy@ragM&YX_?=t&_*&`6kwZhFwHjd? z0&2ftnrL7eitSZm`KkU(mKOe7SBsZL%i`|bZ+^vX|A2Dwggm{J?^&`s?m9vEw8s8o zhs1$0j@(Rb>V~LWdPkL4KYuPA&3m5=-(JEe_^B>D^Xjv0npK5dQm@}XVpqF+;nJX_ zLVuN)ruYXg`A`XIoWI@yt~U`LAB5?e^sGllZgLI^9pK~Kw0X6Mw|~O=a#&^ZF(L}9 zuNxwk6;F zu2z_o_F?y;wR|YKu*CUWfPs~0YS+eb;_^3^KD?G&V>+5zW_3XFeC-|)Wk=27K$Cao9#a&Kul+!72iF-aO70tlL-*qZ;Jej*giE|&Fg0WA$ zQBvRT^b3NoW2bBq29;S886qDnFfvvMg~ozAC(JRTyMX{pbChIvQlgV_g*=B&XVwCC zgh!hzt9TQC$h;bPSIjXx9WvvyL{nWvPs)h6L!@(n&l~2!kkC(>@paVXFNz8ex?Y#x zC4|YpE)1jW>60`pmM$&0XEu#S6WKXej{BQT+~vXK_*+Ga1ho=<)$S~o^cLk-{TBQZ ziuRRa-`B|`$D4<&ZEkz+obux&QGT2lJ6*F)tUixfH?m+NK3aK_RqITeS;K>>Ma~wg zoOtQLsl(|7hfJ+E?WTV1WN^GY{L%~ZjyNVe!BB-F7rLNV)upvxs2L)zZ%w!s{OMv? zCSzo18yOW9+aYFuy(N!*D)DOk0u##|>5H50hjAs!klhK)?~-5*B(m+)+e6en$v8Hy zr+LDvd_34mFj8Cl!l?P`LXF=AlbTuwE&fhFM!Kq*i4@gr@iTN3mgG;iz_)f|y)HqI zQM#T#-|!&;aneVWmsGe4MWTrqnci4_z~FEBVelnHF{`T!Q`Xs!$D-e}k_*y}lI&s5{qYkK#wmlWm!;!>o1n|B?>KmOX#u-S=? zmi}Pmxh>6MQDOHecWp|xWLC}?xqEGgK2G$&&8iaWl*#LYIX75{w{CjQLbKHwpKrRV z&a})Y)z5$Rrq+#gt;YFRuU`4)o?V0RM=keVcJ0_9>D(_t zEG%(kTfn`u{Bf)>NpW+6tZJ5}rpm;87NGqQm-y zT!tD44%ia8y7_F>9M)7}8A&-_w0n;7mB{|u`OMTC54-2n0>4SHHk@vdeX?4U$GkdG zZu&AAEJuXl6Dj5BDQoyy%Nj&pI6OQ=%ED+$U%J_KmV`oi*Di+}UUYfGD%Z_7U0pC5 zYqpv;a~x$LmB$}Xq`viR?u?1@#s_pnj8h85*q&9|gA!?G6+^YD_ku%5WoUE51utDX zETZzQ`B)b*arY%lXNUQ7lq7p>dMMz}!J447KdnruSNz-v9i7lVKHdfH3^GxTOYdwbPI z;%+N8!Bg>{4pyH9%VICtFDOtMf{;mo#p@+gCDjjgs)E6!Y{LDO^}&V%+g@A}xV%Z@I>E7b5cW&>3 z`|Ay9-_{@CWfk?n;M??XVi-7e4il-|_M8;kx~%A9+85Ltj&JmTc@00TJY&4FPk+cs zU~2d-#chl^Q@6aTA4T)vP57|*6z;a11KYiLhwBtHDMFVR@n&^5F~0D1TEsD|`=Qfx zqx#30rQIGcM)&SL51*gPyKb@T`E&j_4hzZ_{pOw{I)RY z55$#}I=gps?h(C`WbIgyt>VaYIpT%EP0X>R^F(oh1uDb=^Zd46w9C`Bdj+_Nxa7k2 z#JZXiNAhc*qR4Eqw`UJmXA<`z>b$*`Z-Z2g`^FngD*n9+j|Ihd^t}-5H^Lq!qxBj- zELhU*kdUN^|%(k1dU<|Qy z8pkYHmT4#~9hB*I!{5-*W0Uy6b?gEwt5oIl%-&vFMvl#mGD$bE=Nj3nYjL<|*T%E@wg*fr3jFUL5+vQq6jipB29q~y3V+NpmnclmUW-_b zIKbj^{z1kD;%7b7Vwh_#D>=-(#|GGF6{B_b^Ghv8M}$9G#@0(`N_%*youGa?me&ZP zl;&)zt}9qra^kboun$-d9&};2V2m9vu;1dl?e0AV3yFhLQsuT-EVia^f49OzsT~ij z$rOgNglSYJ#iTJrPC{oqUTqueo$lJ@O?|C+(>7BIPLqKNiaJf+z##C#Z<84D<@9&j z_q{I(uxfneln3w^kxz!`rN~h8>oMJUc&a)3Zt-*n=_zk2G6q@`{kd4%MAJstZZt^aikkDm9JG0R59 zahL(B&GdXa&5gnio6|$2yRutua*|MUQ*b9Fym+1~L)Hun5=~YdB z_P&iO^zs$Sb4HVVhBJMawi|CZ-)^eYYW2v>r*+}A;+!3xl@>#t-Mh6abN_kGZ-re{ zhmT~PIn2u|AFZ}Rv^RRoiF(RyEUb20G1gR6C(J7uZypt(->}^q^Nj9{R4(NqiHmM0 zNbtQ={Yplo+g{(O6Tq( z_ng4&PC?Qf^a|kJbsQU-n#9gAG_L4&#D@meUcnFrB;6(6R<-Gv7nf>&d!U_NBF$Sj zwd+1XGFM(O^6*fVJifj2MsCotDk|3*G7% z;MA^96ITM?V}z{goL7lhtcit4AKNo-V__?r*+ycxla1|@kilj417uEx5%dvcQy~J{ z6ar=24()u#8*M3ehQ?KP#jZNp1M|#X>Cp1Yn*lU2L+mfjY_40(bCc0p78l6GW`Aif zbXQ9BGkaUw*Szlt{ty->hII$|S~Qv9f<%uIl`wyxD01;^X_A9IXMbbK_bV9L@sXKwteSLrSqoEaV^7| znubzDUHcS2)ykX@7Z(rSWvC&-SfdjBiInjHu}B%&Ry(A~Xz;1uV!Z@su=dgk|Ki*<8{t^N> zH$|^Du=Ug)foMhtot2BuyB`V4%Qx}f8;z~k;`zXR%!kc(mBdM2TKKir6P2fyaz_P{ zUJ5)sVCfMC^71Q8<`x?H4Ci)D+UTEs*llpObRfXb1U%@CpxY-E8k&`rWv>(JvVGUx z_Wfl06c(-}xRYeI2EDR;l%tfV$7)O&U?wQGfq0Zd;Kb0Cl&qcthiZu{l1EFbswN(= zcvJkl8+mwkh*XL>?BB?{ap|y%f|;pf%7vKu2a>YRF;K1z>1#A!tdzKJ zu93(+B;=pf-dn>o^# z6kolLPB~uF#ev=T0+KWhu*LdY`T!pv^MT{XSvfhY zx^kt5gk4E8GZJuSg3>ca&;13udCA6WqA5(zu0GH6)i^i2>6Qz8=IWN0L`XUF^jWVF2pYL=Z!J@Y9c$0_QFvewaU1#NTrtUbb3#m_dzLsNw#3F z^QTUox=^GcAt5PQSvNWtzhU!XL)zxCrw$#usf|rdP20|8*XqQd^gI8YX8h@P4ceBy zX}5faDmoQ1Sut4uCcyFJVg7bH%tU9#QkhTR|xwOSjc&;s1y zGfq~V%{QavL$5~0^J+z!KX~6ZZje62BEfKV!L0J0=)n=|ufzJy`?f5)bX>$l9o(;X zHBPeqs0D+<({rgkCi-@hJMg;Jkav3ot_cV>Jx<*)ku9GT7%N!N@!+%l*j>|XojK? z6)iKWnFZJ!u8|qJ;gn%Mp-&E_<2tn3NG<;BiS*N+d=|#TpaFior0#F90Bc zg&6%0vvn&aDd7YBa|jkLSX5wvZ@Ytk|L+}V&YanC;R4?UK|w*4iy|WW7ez%~M1_T2 zgarj%g!y5CH98l+DCTnU;zfNyK_L}%J-YAz9;*M`@}*0cowPKy#;h%@fSr{!urf6T zMvor@J#B5Eaqk|ur>qQAZ{G%LN=iUoO^xt9`ainP-r5?V`|jUYA4Bc@XKMd@SIElB z#aUTeE&6=;06aZBz#C_0@Y2ri5BvzX@~vCn@#|=407HF!U}9th`)dW9UcLnGuCCyn ziwiI{Fw{j74<*r2c>QjjF0z zwkM>4aEFJ4fRFzE1l}Y32!jX2kn{O7_}bVAD$2$|dC3?k$X)tgvNOj(CH($tQxnMj zoDDuetj@0-31hd8AMu006WErj>fP-BGsJ6m%gSD-d-~+*7?P7fUtfTDkFXRL%W#i!v>k@BgdHcMUFAihYvE*g~0Eko7tHvhjj1H zttQ1R!oCi|`%zy!2<;*4{$5@nz{iJB8yP(tL-haKe#px!(pi{Wj3FK)yr^wdqmrMK z3))&HfrW9$3^RR1H{1U7xg#vC;GdL(jJXR;bf3O)FjWm%Jja8Ys!5Qan@8Y1!v1ry zv$Y#TIR2-7xN+kaovpPE0XxEv#v6@6XwWCn($WKbK6K48(T5HE6TJWK8fN;aQFf;C z0hgC}$d7LzA~cLJ&Oi6T-rjx;;rXBR!Q9;ZJ9dO0VUGw42OVwG;QXnio+B*HtN#wy z@BiaD(Fs)br@+N4{ebge+aKeE}qMz6o`q8`lAmP7S?0`6u-W{LH3$_dk}CV zxy*rcuB2!l9A*w1{vF#tIlp#m1Q^(1fsO?h+c8xTw&RlF#S)k{(jBzBke%b6btf7 z@nC#%5tup80TtazaD?^G`NGary?lh_>qN4x+-t0sLV`LP4^H@cp}SfSx&Q zL})0K!%#Smk>GPi7HDsq0*9CqXMV?p&Uuax03NP>aGawDa2@UfT#w>*%Zk^<6_ zlL^K1gBSMi@EaHy#wEqZ0#wlTIa!}USH~bYb~tS4udt)$08Nuw zkn|Z3mLPUiT>a+3tq0?OiG7{UL59zBqUYyVTbc$zQ9%LhM=n98&>n+u{#74f!s239 zdOFC?%mf8_`JlP689X!0>R)g3@9J~BqX6OjtA0q!PZMN*YG#puy}NIb!21h)-~KIr zL<_F5UC;G#aLs53RpsSyPb?vn__+AR-|=f}>pJCRWq~}npA_cj!~Lin)K(8bS#0^Y zbk6a1gPRYgft1`7xO!t6h=@)C0fDu`cYXpqc#Z`j@wo52f8#$7)E-U!+ctmZ69-fE za8bb|fT0smTUA9U6=h`r;r+P}?>*j+p)o?Gw5SNQHn)H)ViA2mx3&J+*J}cSAXmRnRr=}5jpHIMF3@R(y7TB2^|5)RnJ{kn; z$J>uMVC6OsB9a$CY{mjuU0wgrTJ7+D9(ab#gIVknp+<97P`LLWV_)YN+}{Svibe_e z*T(?Kx48JFEocn%^d327Wn_SCC_e=J#U;SZB&m1({`LAScRR2)9|j-ZjRSArX#y{E zO4j5#HE;13@NM18g#VXRF8~wAIVeXn;QYCs|1ow%n~6T8&(#qNnjrtHD=MIDmw~e4 zVx;4-Bm8!D_7&-=sQ{JFaPHRE)xk9KFZw0)AWAoU44m@#~1FCvc0PO+m?fg$`c9zCfk+U-^Z7nSX+{J~302OU*9T9}z z^Sx(pa(p~UPD}(Dun(0LmH5A+QILxzfE*fJ0?%GxK}`Ar(6^ZbX+QCPWPF9dcO>@@ zEwSLf(F_n4?E~DLf9|(`MdR+O^=&90nQ3Vt3-bAqp1uac9~%=3b+a%+ ziG}^JwTk*f_HWC70~6yvgaqM9$yo$CkjFpI+ro+^Lf>9{;lSv`+Js(&Qv=P1^!!EO z5sU+m;9iXGM+NB-0)qc&FX(>bI07=^zM2g8S5%%nHYDJWhWcLUr%!|u6&?X@$c6r~ zZmO&FedlrWS3Ch@ER>%|wsYUVU;ofIxB_e--_bar{`}Q}iUoPk?!d4ISG;>?r5mfq4HQy zkAOcWDjJ0Si~o^O$CJGD=@0w@ydBWLFbwTiJfRR6}6ZFk+$opt0KPtBa|Im3v z`8vVK$Pb)xakId}bsl_y^5F^b;c$QQcfC)Gi>rjOKyw1knFV-`j=a)EVB<0iPI3O{ zwH3*aqs;(FjfnxVP%kFPkHMP!M@2*ubmb`6uUI%2OrM4RF@L!^+Q8)G+WZ|IT>_Dz zP!|6+A4{s2Kxo1Oz%TrL9}wR5o)yA)eF(vUZv!hJJZS-#T2FyH3ccWp$iJ5%sLORn zeCk@0e>et7upj#Wk{@qRZ^HVYh~_oi2f{)k{&M~F^_)O3fXnMqFg3YC!0Qu^C&+hs z-4Y0jMfSoY3Bf#=_AD2lNa^3HVVTISFc^ZTx$ar1z zGGR|ca`9JVu>!k>`swJ61J;f+;3ZrG)b9^`$B+6TbNR1zJ8q7=F0^+MaKbh8Gu#98 z_4En*uaS|lQ!cbsa*_TF?E|#8ojwu$i~hiUq>Vu5u2L_7_v;<_+K2~TU5g+lZH=dh zw?&mpprU>W+FPpthhGH)!z%#Em?xAQg#GceF+y8vO8r1dvG*7Js1L&DJAYY^kUjQ9 zcW5OaV#`K)8Z79uhK4pl|G9PRHV^VcAv*{4u^84?=6=8I0b&AO1UjL?Q|r(PbyC6% zz|OA8On3hZ`0#NKxcK1+@_}Szy`X(7yLb^yOu_ZYWBd=y2={uqDfg`n__2yu1QI|3rImaL}i*a;VdlL*2g;+BtA67CD$3R*)Q>0@IuXuet$HC0ZpYyt=3J1`>zTWQ7^(CRT^@w$U^0bF*JE(xXE&K9? zP**|y8R1>Wj%p}FbkK*l*icggP-%oZbZOz26%OXc6>-5e+4;HsN7@6>U$y}4;~(}6 z>PSDdZ-e}Q%y0A^(wpA7j-ii#9DTiuz(D8MIgIG6;}<$#K2iqxT?6f3R1jYg&Y!Wb ze|B=$GQBb@7)f3LGLval`i8dO@L zuN&3kB3?s?A3wLh{`raiAZUQ{^0N+VVLS{FUw=MOzpPA#!QjA;J^Yvd!v=gltj+72 za^JwQL)mkV_D!H3$^ydO0$Bstq0vfP~m-Fa_5aw9h5Q&-@IJ@VTRX0a(C3tgQUGPY(|-5$?IK+y_L?H?Q25 zufaCMSOSs(R1kJ#e<6Io^ZfU7UthoMj@DLyN>_V3=jNW$gFsHkfAnX(fA<-!jrLZgwunN;d;X{!cKYdxbB=PdqnF8*PKKIta%X@gB)e1H_H67k&9MhH(5-%)ejf z=;%mSkY6y?)7eRw2g8uY#5mfIX29(1EGR20pD}zC)GsBTi~Fa2k(H=j6gnR?;P@hA zxEr=RJ~jqMhK4}jw{HZwX@P48DsY`2L-c>g^xvFEMMY%~LF{M_AbMyF5Pp~v3FhbL zVLc1=gwkox_c8r{qrH837WE&N zsmaMT{IK11+4%<7i>Sz`e>_+JX@A_`x!;5FPweEx#2@%^I2>45SOAOA*{}?a-xavv zul{ROK=mp-N8h9Wpe2>kyY zKLPVU#ElzqvO3C z)%`F2t@9J!$bk5`&ToQJHQf}p_2)b;5`^lHJT6A~od7KVTX|eC2TNW?O3Lo4v`q9> zDXHu$mo8;r5)&iTSEZ%1ugP46-^mb?xmE+vG^K?qLmEvB%e7Wcj^9fMyj_LE~ zKwn1(+*eg4#hId6m#l`EBXBVMV(L{Mm5U{fTj~#Io&AP3JxSrT(?;Fg_#@<*Q^B&oa#ou#c{Jnet%qOb&PkeyBscb|W6`v2DurKXP+?)aV>`b*w zf8|^I{X29W<6gfw#=X9J0;jrXbF%tCP(Z+U9C{D+{+18-@7;gy19LtQ-%#E~WLP_v zjWO&Of70*t(7Br41W?r(|0TEM5aXAbeY+g*u`^Y4CdZEv{NyMH4Eg)j??3oM9z;bi z()s)NEutK;Sm;+zO{tzae4yYj<6%EzIDN7U7{9`T{4zYyHktV)M}~vBewluklRAup zb{6CgLf=mkNP)4okl;^?h~Cd*VPb3&hjJHC9zbPT;|d3B{N&GcPIC5w)7(R_48S<~ zC=eE&0Q`ItKuvc76jv?4RcQ$r*v$UI19blyhF3TEPk)m|&-m_3d1Cm~3FY0O{DGX$#lPg6Apf?scsG!_J_J}%9 z2BPAVKuL23`uFhwJHG^s9A^J*JO#-l%z^7_sOtlD(6@k!j<${j;(_BU_^=oB!J?cK zb+wT1@`mEhz26o=5A;u3xXuycf;~OUP(d7uwtWr9NgEH=-u$K6T$Uhf?8YZX9WsHKIaH=-X8V*)6S8Xg+{i|-lv)R6DP z5XPfjd~t+WBBCD+eaGNrKK=ODGfN-+C?Gy zD2@^q8Uo(9czw^SLvgF{kSWmLzeI?an>x*XR|{?4&V$6y3!t(A#!uq$z!dWTq4_L$ z@OTnP$qxRl9H4a)t=Y(rnh5)BV{S>HkMiR_1$_k1jaJZ0Y^&hR-Ec;>ui=muH!uHoz!=B6d9dDRd6~;G^PXNVkQT%OvEYSE%U(PB) zG59n{&(h4CApdTzZz@m>=5u=b3O8r!{QC9Iuiz^!gVuazZSAoAu(eo3e%T`EANs*_ z6obrw{eS%)%8BdjFaD|PF!qG{g4%?6x%H2<8|P6j0OEnEu?b=RTUuHSZ-(n9-ux)Cd>omgZwLBh|t-! z`N^=yGcq%!iVzPefqQ_V;S&io|Im?_owJBy2pOqqb4OX5S0yiY6X;h}tgShTaXa_x|GRTXnXbIFbg>2cu%HirMU+2gcD)VclXQ9gBaV=fIt#{s%E>@+ z#dRJa9LvkAz~k+YSk-x+?8(9=!}$SY74X&I z0QsXO#0uwZ%rpCuUvteL+W>+-2K}x6w~iwrA)%rZ(nr2m=$l)9ZuIFN`Ht7|p;|&L zd>|{MVvdkM2mO&v&=(K$7c16j{HGf3N!iH%J~S`@ke{cfx^Bk!S?GwuwbI3(>HPdz zPO5h4`qjwc=*X;*G3e_XfWB|!k8X$K`6(#)Klb}~Or9S+pLch4FCzNLXNdeD`L?Iy|zr+~-TYCR5?gQN<0Qw*-R-tzWxf+n$0s1h=yP+E* z7rGACizNnw`KM+59#nV3c2Ik$UDQ6JgXj_H!m)cn`LiE`6oZc6pGVsbzvF`Czx89l z=d74jRa7lim6Sto-?));{p!`?Yf{q1ir23fE8n@3qRb3cl&z&DFwoT{_$5?s-vL_c>M%}h2wvFQLi^bjSejdm+`D`4ANfY^-McU3 z^y>BGCulQzLwhtfDjoy}mM$4TEt+_uUxhW$t-~7Xm5;x+Z(N89%O&_B&~?amH8U}d zfX~m6|6O08{VDG1=(vb%`{;;hxK~up^PR53!aWk^P5+wP&(2)GdiX%;%mdZ0*o2r$ z!ZSeV84*hhi!AtT$R9M|GZb8JTwE4Ez-N&X;#lfr8s@hwf~0I5{QlS68&0+g?C10@Lau9Mc*MwhAK>#DohSz+E(Ybf zuJHur7~F$;(|!F(pz&}9T#=pvl2TLPeegUXfBWxjT4lx7dGyR!4a^I$v$a=(`#IO= zj7;za>Qx$ds|h;fF{t+iLEYd}%se5lx4CmomrH;;a^hzk(0nrax6eYLG0)5HA>$`V~$1|W^>+a^31oJ~JLxO{096j{Ajvo^_1@~1Pc;k;F*mJ0Tlz$bT zyk<`zJqjI2*Oa|8`dx$8Tyh2-vXgH?p_6}iv}ePC<$M`g_d%=^QG)Z7I^E);6}E7ZT;1K{%rPse~V)VGi>A||k= z>vJ$SgV*+D^T^J2fBViG=Gjm|`CLT#MCvN}^GG(4eYBq2T~!J9c9=7km_AR)>kf^@ zfri#4xTh|{yp$h0J<3N$IcY~(OJ_c(m4GjBKD~8&XO8BW*9XrqlqZuIn}g>)(YA{4 zpj?-#ig~zRtm&)h`3ZD<>sf#?<29L@g*iqj=D)5>A-~HbosxN!k5yh=vI=vCm{I#M zf8|I`MddQet1y0&KC1xnqkB*;TVnh)!7fC$2_C;@kRX~1uutefvgGGI4iJ8E!7tdd z;u=CuOmb3kIBI+S2n!8+(GK$;x}pB5r&WMo$AoGlgF)~f>h+c7YrcT_`4vL$2%=Y3 zG6&^+49H3}E~ck6ETdeY@{-a?nD?<~z3ufnEj29*>4iu?dtq0Ay(QmG;MF><2Wow= z{{w`AY`VKjYj)i|rQ*4gFU`xyj(|S2MSp*Pq4hR@u3_Ar{Bu@T);Fj>kByGPHKPe{ zZd^HcL$>vg+=ZKRovUiMOJ+a*f2|yCOcYme(HavI+y3-NquYg8r5jn#@G zq98=urakW#*mAcEyL-ps7ueXe)}mDsqb0poELKvKB4R@|Rg0;GP(Y3H*aQLjYD`2j{A=bP0fCn%e6EV=d@4}5dUcdYV)_xiO?Kb}|P*}WTd>4x9yF9WYZbz)o> zw4GC1TYK2!>G9)PC!TX^y5FNwopTU$-quU4*Wuaajtl8C8o`<3)T*kgwA)>`ouJPa z!pl?$dTwDuLxUB3F#fZ@kEsIIN6ldSsmbgOY9f0^O<`;yg^6N;9#R5Kco1il+E3GSZO(_V%$8q#?6v=xbovmlnD9?o{$CHoHb$>OPj zts5^5Y;iXATeGU}Y}>lO^W%boP9-hlTc)oW!^Qrwq2cEDGmegHYrP3F!X zc&v-K+N+Cb>zO;t`^YeVn9Q3!4C~qhag;~NzT#s4>Q$>=*Wka{{<){7s+y!M|Fb{* zmGbV$@RpIt@QZ57R=P&=HdK4!W1D&r#|LQxU<<4v1)H|iAw1Yki!fF$H~Z{u^ijol z4C9;KWZAM_lAO{9F?+-0lU-g_Ud)_Pdk1ms{InPJw*%J^{_B#Gj-P5yt9%^&+aOe! z*f-xN*}^@tZPy?t$=bHZD_h~xXRnrjGu0_5=0xA$E{IfORK{bfT0WqSMH zU=s$}oBr;TvLs^qkNpV0*?IaF!k2@sb52B~5A9>;ejOxxAg-_z>`53ePzLtQJzouw z4dCCMzD~o__E1vE3zAm6huJ z;TS599BEHU`lU_dnRRCef_{>yQ#^PO7z_HWrzJJ_{ZZcv&%acCe-Pf`aKs%ycI?Xg zYflAnpq&S4qMtGPRpx-N>DtueH(MJ2A|QACiY(7WSnYB;^5Ve1>~it$L)9OytGo4H z+EuV|b%2by;^(>Y_LD!Kzl%H%bV83^vHz>jLiyptJDZxCy1;JZT04aCO|D=GsbJAyh|G|X7pWD%(h{g7NQT7W zZWQ2F$d%l%p9rI300HLkTPPDKnjXyo`KbD)cPyfAMrGgc~? zY*4yF>r+%ZFIdDpIckw;vx$OkktisVXq7`Cg7Xm{6@$N!svP@zD{o%T<)@0-9L!jJ z+#7N0<74%)v1W6I-jWg0)M^qk?WRni9T`%ZBZ+2CmPLt`%vrp`nH9UFHi_1T9<9yB zlVdjo%SUI)phyr_mLOz^<9r757>$I?ne7rx-Poi`T&^9S4QEM~cn5FgGC4U|33DE- zUhD)=1zwg!&cRv7CYh$KSYTvKa)RK1xsgJ~Ow)FrHRG_2OoquSbBs1vd~Sy5Aoiz- z8={}+sv$Z!X6T(ET6+~BgX@B#4C=c+g-WIpVWp)~OJJ3)hEclient) + function GetClientCookie: string; // Cookie: format... (for sending client->server) + function ParseValue(Line: string; Version: NativeUInt): boolean; + // parse either Cookie: or SetCookie: header part, 1 cookie at a time... + function MatchPath(const aPath: string): boolean; // is it cookie for this path? + end; + + { THttpCookies } + + THttpCookies = class(TCollection) + private + function GetCookieItem(Index: integer): THttpCookie; + function AddCookieValue(const Value: string; LParam: NativeUInt): boolean; + function GetValue(const Name: string): string; + procedure SetValue(const Name, Value: string); + function GetCommaText: string; + public + constructor Create; + // + property Cookies[Index: integer]: THttpCookie Read GetCookieItem; default; + function IndexOf(const Name: string): integer; + function Find(const Name: string): THttpCookie; + // + // Load cookies from client, used in server... (Cookie: headers) + procedure LoadClientCookies(Headers: THeaderList); + // Save cookies to client, used in server... + procedure SaveServerCookies(Headers: THeaderList; const DefaultDomain, DefaultPath: string); + // + // Load cookies from server, used in client... (Set-Cookie: headers) + procedure LoadServerCookies(Headers: THeaderList); + // Save cookies to server, used in client... + procedure SaveClientCookies(Headers: THeaderList; const Path: string); + // + // Other client-side functions: + procedure MergeCookies(Source: THttpCookies); + procedure SetDefaultPath; + procedure SetSameSite; + + property Values[const Name: string]: string Read GetValue Write SetValue; + + property CommaText: string Read GetCommaText; + end; + + // HTTP request and response object + + { THttpRequest } + + THttpRequest = class(TPersistent) + private + FHeaders: THeaderList; + FCookies: THttpCookies; + FParams: TStringList; + FPostStream: TStream; + FUrl: string; + FMethod: string; + FProtocol: string; + FContent: string; + //FContentStream: TStream; + FStatusCode: integer; + FStatusMsg: string; + FConnection: TObject; + FFlags: integer; + FResponseSent: boolean; + FCharSet: string; + FDocument: string; + procedure SetHeaders(Value: THeaderList); + procedure SetCookies(Value: THttpCookies); + procedure SetStatusCode(Value: integer); + function GetFlagBool(Index: integer): boolean; + procedure SetFlagBool(Index: integer; Value: boolean); + function GetStrProp(Index: integer): string; + procedure SetStrProp(Index: integer; const Value: string); + function GetDateProp(Index: integer): TDateTime; + procedure SetDateProp(Index: integer; const Value: TDateTime); + // + procedure ApplyHeaders(bnIsServer: boolean); virtual; + // parse Cookies and possibly other things from Headers... used by TSynHttpServer.ReadRequest + function AddMultiPartFormItem(Headers: THeaderList; const FieldName, Content: string): boolean; + procedure SetCharSet(const Value: string); + public + constructor Create; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + // + property Headers: THeaderList Read FHeaders Write SetHeaders; // Set assigns copy... + // + property Cookies: THttpCookies Read FCookies Write SetCookies; // Set assigns copy... + // + property Url: string Read FUrl; // '/index.html' + property Document: string Read FDocument; + property Method: string Read FMethod; // 'GET' + property Protocol: string Read FProtocol; // 'HTTP/1.1' + // also MUST include Headers['Host'] value... + // + property StatusCode: integer Read FStatusCode Write SetStatusCode; // 200 + property StatusMsg: string Read FStatusMsg Write FStatusMsg; // 'OK' + // + property Content: string Read FContent Write FContent; + //property ContentStream: TStream Read FContentStream Write FContentStream; // stream is owned by the Request... + property SendChunked: boolean index 1 Read GetFlagBool Write SetFlagBool; + // set to True to prevent asking Stream.Size and send in chunked mode (without Content-length) + // + property Connection: TObject Read FConnection Write FConnection; // TSynTcpSrvConnection usually... + // + // Params contain 'Name=Value' for parameters in ?params in url and for POST params inside content: + // When posting files, Params does NOT contain file data, only FileName, use GetPostFormParam to retrieve file data... + property Params: TStringList Read FParams; // use Request.Params.Values[ParamName] + property PostStream: TStream Read FPostStream Write FPostStream; + function GetPostFormParam(const ParamName: string; var ParamData: string): boolean; + // get 1 param from multipart/form-data or application/x-www-form-urlencoded... + // + // Common operations for application for making reply: + procedure ServeFile(const LocalFileName: string); + // open file in ContentStream, set Last-Modified, Content-Length, Content-Type + procedure Redirect(const aUrl: string); // set 302 redirection and Location: header + // + // Functions used by server/client: + procedure ParseFirstRequestLine(Line: string); // parse: 'GET /index.html HTTP/1.1' // used by server + procedure ParseFirstResponseLine(Line: string); // parse: 'HTTP/1.1 200 OK' // used by client + function GetFirstResponseLine: string; // format: 'HTTP/1.1 200 OK' // used by server + function GetFirstRequestLine: string; // format: 'GET /index.html HTTP/1.1' // used by client + procedure ParsePostFormData; + // parse Content string into Params, used usually by Server (for POST requests with propper Content-Type) + // + function MatchTag(Etags: string): boolean; + // Etags may have multiple tags, comma-separated... returns True, if some of them is identical with Etag... + // + // Common Header properties: + property ContentType: string index 0 Read GetStrProp Write SetStrProp; // 'text/html; charset="Windows-1250"' + property BaseContentType: string index 1 Read GetStrProp; // 'text/html' + property CharSet: string Read FCharSet Write SetCharSet; + property ContentDisposition: string index 2 Read GetStrProp Write SetStrProp; + // 'attachment; filename=targetfile.html' + property TargetFileName: string index 3 Read GetStrProp Write SetStrProp; + // name, by which this should be saved by client (in Content-Disposition) + property Location: string index 4 Read GetStrProp Write SetStrProp; // Location: header + property Etag: string index 5 Read GetStrProp Write SetStrProp; + // Etag is used for caches, so that they may know, that their copy is exactly identical with current data (having same Etag for same URL means it is exactly identical...) + property Host: string index 6 Read GetStrProp Write SetStrProp; // must be in Request + property Referer: string index 7 Read GetStrProp Write SetStrProp; + property UserAgent: string index 8 Read GetStrProp Write SetStrProp; + property Vary: string index 9 Read GetStrProp Write SetStrProp; + // list of headers, for which the response varies... used by caches... + property WwwAuthenticate: string index 10 Read GetStrProp Write SetStrProp; + // authentication challenge, used with 401 status-code... see RFC2617... + property Authorization: string index 11 Read GetStrProp Write SetStrProp; // Authorization: value, sent by client + property Boundary: string index 12 Read GetStrProp Write SetStrProp; + // Content-Type: multipart/any; boundary=0123456789 + property ContentEncoding: string index 13 Read GetStrProp Write SetStrProp; + property CacheControl: string index 14 Read GetStrProp Write SetStrProp; + property Pragma: string index 15 Read GetStrProp Write SetStrProp; + property ServerSoftware: string index 16 Read GetStrProp Write SetStrProp; + property AcceptEncoding: string index 17 Read GetStrProp Write SetStrProp; + property ContentLength: string index 18 Read GetStrProp Write SetStrProp; + property TransferEncoding: string index 19 Read GetStrProp Write SetStrProp; + // + property Date: TDateTime index 0 Read GetDateProp Write SetDateProp; + // local date of serving the request (is converted to UTC) (filled by Server) + property LastModified: TDateTime index 1 Read GetDateProp Write SetDateProp; + // local date of file modification (is converted to UTC) (filled by ServeFile method) + property LastModifiedUTC: TDateTime index 2 Read GetDateProp Write SetDateProp; + // UTC date of file modification (filled by ServeFile method) + property Expires: TDateTime index 3 Read GetDateProp Write SetDateProp; + // UTC date of expiration (for caches, allows caching of otherwise-non-cacheable responses) + property ResponseSent: boolean Read FResponseSent Write FResponseSent; + end; + + TSynOnHttpGet = procedure(Sender: TObject; Connection: TSynTcpSrvConnection; + Request, Response: THttpRequest) of object; + TSynOnHttpExpect = procedure(Sender: TObject; Request: THttpRequest; var bnContinue: boolean) of object; + TSynHTTPCreatePostStream = procedure(Sender: TObject; Request: THttpRequest; var PostStream: TStream) of object; + + // Virtual HTTP server. + // This level does some RFC2616 stuff for you, + // but it does NOT resolve URL->filename, which must be done in OnHttpGet method. + + { TSynHttpServer } + + TSynHttpServer = class(TSynTcpServer) + private + FOnCreatePostStream: TSynHTTPCreatePostStream; + FOnHttpGet: TSynOnHttpGet; + FOnExpect: TSynOnHttpExpect; + FCertFile: string; + FKeyFile: string; + FKeyPass: string; + FCaCertFile: string; + procedure HandleClientCommand(Connection: TSynTcpSrvConnection; Command: string); + procedure CreatePostStream(Request: THttpRequest); + protected + procedure ReadRequest(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest; Command: string); virtual; + procedure DoHttpGet(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); virtual; + procedure SetActive(Value: boolean); override; + public + constructor Create(AOwner: TComponent); override; + // + procedure InitHttps(const CertFile, KeyFile, KeyPassword, CaCertFile: string); + procedure SendReply(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); virtual; + // + published + property Port;//default '80'; + // + property OnHttpGet: TSynOnHttpGet Read FOnHttpGet Write FOnHttpGet; + property OnExpect: TSynOnHttpExpect Read FOnExpect Write FOnExpect; + property OnCreatePostStream: TSynHTTPCreatePostStream Read FOnCreatePostStream Write FOnCreatePostStream; + end; + +var + // Value for Server: header... + ServerValue: string = 'SynHttpSrv/1.0'; + +function ReadHeadersFromSocket(Socket: TTCPBlockSocket; Headers: THeaderList; LineTimeout: integer = 0): boolean; + +function SendSocketStream(Socket: TTcpBlockSocket; Stream: TStream; MaxSize: int64 = -1; + bnHttpChunked: boolean = False): boolean; + +const + cProtoHttp10 = 'HTTP/1.0'; + cProtoHttp11 = 'HTTP/1.1'; + +function GetHttpStatusMsg(StatusCode: integer; var StatusMsg: string): boolean; + + //----------------------------------------------------------------------------- + // string utility functions: + +// Trim(Copy(S,Pos,Count)); +function TrimCopy(const S: string; Pos, Count: integer): string; +// trim inplace: +procedure DoTrim(var S: string); +// remove first token, no quoting: +function FetchToken(var Line: string; const Sep: string; bnTrim: boolean): string; +// "Quote value, using \" and \\ inside..." +function QuoteValue(const Value: string): string; +// remove first comma-separated value, possibly quoted +function FetchQSepValue(var Line: string; const Sep: string): string; +// for parsing: remove first Name="Value", separators either ";" or "," +function FetchDequoted(var Line: string; out Name, Value: string): boolean; +// get value from Name="Value" in multi-prop header value: (from 'text/html; charset="Windows-1250"' can extract charset...) +function GetHeaderSubValue(Header: string; const Name: string): string; +procedure ReplaceHeaderSubValue(var Header: string; const Name, Value: string); +function CombineStrings(Strings: TStrings; const Separator: string): string; +// SameHead == SameText(Copy(Str,1,Length(SHead)),SHead) +function SameHead(const Str, SHead: string): boolean; +// multipart parsing... +type + // Result: True=found/stop, False=continue + TMultipartEnumCallback = function(Headers: THeaderList; const FieldName, Content: string): boolean of object; + +procedure EnumMultiPart(ContentData, Boundary: string; const Enum: TMultipartEnumCallback); + +// Date - in HTTP (RFC2616), all dates MUST be in GMT (utc) format... +function FormatHttpDate(LocalDate: TDateTime; bnIsLocal: boolean): string; +function ParseHttpDate(Str: string; out DateTime: TDateTime): boolean; +function LocalToUtcDateTime(LocalDate: TDateTime): TDateTime; +function UtcToLocalDateTime(UtcDate: TDateTime): TDateTime; +function TimeZoneBiasTime: TDateTime; +function GetFileDateUtc(const FileName: string): TDateTime; + +// Content-Type detection used by THttpRequest.ServeFile +function DetectContentType(const FileName: string): string; +function GetContentTypeByExt(const Ext: string): string; +// RegisterContentType can be used to register content-types by extension from user configuration: +procedure RegisterContentType(const Ext, ContentType: string); +{$ifdef MSWINDOWS} +// Automatically register content-types for all file extensions from registry... +procedure RegisterContentTypesFromRegistry; +{$endif MSWINDOWS} + +// convert 'Documents%20and%20Settings' to 'Documents and Settings', also handles utf8 encoded in %C4%8D... +function ConvertUrlChars(Url: string): string; +procedure TryDecodeUtf8(var Url: string); // used by ConvertUrlChars... + +var + // location of /error.html file, used by THttpRequest.ServerFile: + Error404Url: string; + // contents of 404 error doc, used by THttpRequest.ServerFile, only if Error404Url is empty: + Error404DocText: string; + + +procedure Register; + +implementation + +procedure Register; +begin + RegisterComponents('Samples', [TSynHttpServer]); +end; + +function SendSocketStream(Socket: TTcpBlockSocket; Stream: TStream; MaxSize: int64; bnHttpChunked: boolean): boolean; +var + Buffer: array[0..16383] of char; + BlockSize, Size: integer; +label + _Complete; +begin + if (MaxSize < 0) then + MaxSize := $10000000000; // 16Gb... + // + // Send Stream, without asking its Size... This allows sending from TDecompressionStream etc... + BlockSize := Socket.SendMaxChunk; + if (BlockSize > SizeOf(Buffer)) then + BlockSize := SizeOf(Buffer); // no real need to send >4k packets... + // + while True do + begin + if (BlockSize > MaxSize) then + begin + // Last block... + if (MaxSize = 0) then + begin + Result := True; + goto _Complete; + end; + BlockSize := MaxSize; + end; + // + Size := Stream.Read(Buffer[0], BlockSize); + if (Size <= 0) then + begin + // EOF + Result := (Size = 0); // stream complete... + _Complete: + if Result and bnHttpChunked then + begin + Socket.SendString('0'#13#10#13#10); + Result := True; + end; + exit; + end; + // + if bnHttpChunked then + Socket.SendString(UTF8Encode(Format('%x'#13#10, [Size]))); + // + Socket.SendBuffer(@Buffer, Size); + if (Socket.LastError <> 0) then + break; + end; + // Failed due to LastError + Result := False; +end; + +// read header lines until empty line is received... +function ReadHeadersFromSocket(Socket: TTCPBlockSocket; Headers: THeaderList; LineTimeout: integer): boolean; +var + Line: string; +begin + if (LineTimeout = 0) then + LineTimeout := SynSrv.cDefLineTimeout; // default 2 minutes... + // + while True do + begin + Line := string(Socket.RecvString(LineTimeout)); + if (Line = '') then + begin + if (Socket.LastError <> 0) then + begin + // error (either timeout or client disconnected) + Result := False; + exit; + end; + // Headers complete (terminated by empty line) + {$ifdef DEBUG} + Debug('Request headers:'#13#10'%s',[Headers.Text]); + {$endif DEBUG} + Result := True; + exit; + end; + Headers.Add(Line); + end; +end; + +function TrimCopy(const S: string; Pos, Count: integer): string; +var + len, maxlen: integer; +begin + //Result:=Trim(Copy(S,Pos,Count)); + // Optimized - trim before allocating result: + len := Length(S); + while (Pos <= len) and (S[Pos] <= ' ') do + Inc(Pos); + if (Pos <= len) then + begin + maxlen := len - Pos + 1; + if (Count > maxlen) then + Count := maxlen; + while (Count > 0) and (S[Pos + Count - 1] <= ' ') do + Dec(Count); + end; + Result := Copy(S, Pos, Count); +end; + +procedure DoTrim(var S: string); +var + len: integer; +begin + len := Length(S); + if (len > 0) and ((S[1] <= ' ') or (S[len] <= ' ')) then + S := Trim(S); +end; + +function FetchToken(var Line: string; const Sep: string; bnTrim: boolean): string; +var + p: integer; +begin + p := Pos(Sep, Line); + if (p > 0) then + begin + // give part until separator: + if bnTrim then + begin + Result := TrimCopy(Line, 1, p - 1); + Delete(Line, 1, p + Length(Sep) - 1); + DoTrim(Line); + end else + begin + Result := Copy(Line, 1, p - 1); + Delete(Line, 1, p + Length(Sep) - 1); + end; + end else + begin + // give all rest: + Result := Line; + Line := ''; + if bnTrim then + DoTrim(Result); + end; +end; + +procedure AdjustHeaderLine(var Line: string); +var + p, len: integer; + Name: string; +begin + // Right-trim: + len := Length(Line); + if (len = 0) then + exit; + if (Line[1] <= ' ') then + Line := Trim(Line) + else + if (Line[len] <= ' ') then + Line := TrimRight(Line); + // Normalize arround ":"... + p := Pos(':', Line); + if (p > 1) then + if (Line[p - 1] <= ' ') or not (Line[p + 1] <= ' ') or (Line[p + 2] <= ' ') then + begin + // Needs normalize... + Name := FetchToken(Line, ':', True); + // + Line := Name + ': ' + Line; + end; +end; + + // for parsing: remove first Name="Value", separators either ";" or "," + // Value may be quoted, but does not need to be quoted + // Name may be missing (if no "=" is found, whole is Value) +function FetchDequoted(var Line: string; out Name, Value: string): boolean; +var + len, startname, lenname, startvalue, lenvalue, Skip, rest, p: integer; + bnName, bnSlash: boolean; +begin + len := Length(Line); + // LTrim name: + startname := 1; + while (startname <= len) and (Line[startname] <= ' ') do + Inc(startname); + startvalue := startname; + // + if (startname > len) then + begin + // Line was empty (or blank)... + Line := ''; + Name := ''; + Value := ''; + Result := False; + exit; + end; + // + // Seek end of name: + bnName := False; + lenname := 0; + lenvalue := 0; + while (startname + lenname <= len) do + begin + case Line[startname + lenname] of + ';', ',', '"': break; + '=': + begin + // End of name: + startvalue := startname + lenname + 1; + bnName := True; + break; + end; + end; + Inc(lenname); + end; + if not bnName then + begin + // no name... + //startvalue:=startname; // already... + lenvalue := lenname; + lenname := 0; + end; + Name := TrimCopy(Line, startname, lenname); + // + Skip := 0; + bnSlash := False; + if (lenvalue = 0) then + begin + // ltrim: + while (startvalue <= len) and (Line[startvalue] <= ' ') do + Inc(startvalue); + lenvalue := 0; + if (Line[startvalue] = '"') then + begin + // quoted: + Inc(startvalue); + lenvalue := 0; + while (startvalue + lenvalue <= len) do + begin + case Line[startvalue + lenvalue] of + '\': + begin + bnSlash := True; + Inc(lenvalue); + end; + '"': + begin + // end-quote... + Skip := 1; + break; + end; + end; + Inc(lenvalue); + end; + end else + while (startvalue + lenvalue <= len) do + begin + case Line[startvalue + lenvalue] of + ';', ',': break; + end; + Inc(lenvalue); + end// separated: + ; + end; + Value := TrimCopy(Line, startvalue, lenvalue); + // + rest := startvalue + lenvalue + Skip; + while (rest <= len) and (Line[rest] <= ' ') do + Inc(rest); + if (rest <= len) and (CharInSet(Line[rest], [';', ','])) then + Inc(rest); + Line := TrimCopy(Line, rest, Length(Line) - rest + 1); + // + if bnSlash then + begin + // Remove middle quoting markup: + len := Length(Value); + p := 1; + while (p <= len) do + begin + if (Value[p] = '\') then + begin + Delete(Value, p, 1); + Dec(len); + end; + Inc(p); + end; + end; + // + Result := True; +end; + +function GetHeaderSubValue(Header: string; const Name: string): string; +var + S: string; +begin + Result := ''; + while (Header <> '') do + begin + FetchDequoted(Header, S, Result); + if SameText(S, Name) then + break;//exit; + Result := ''; + end; +end; + +procedure ReplaceHeaderSubValue(var Header: string; const Name, Value: string); +var + Parts: TStringList; + S, S2: string; + ls2: integer; +begin + // find existing Name="Value", value may be quoted and may be not quoted, Name= may occur inside other quoted value so may not use simple Pos()... + Parts := TStringList.Create; + try + S2 := Name + '='; + ls2 := Length(S2); + // + while (Header <> '') do + begin + S := Trim(FetchQSepValue(Header, ';')); + // + if (S <> '') and (ls2 >= Length(S)) and (S[ls2] = '=') and SameHead(S, S2) + //and SameText(Copy(S,1,ls2),S2) + then + begin + // Replace this: + S := S2 + QuoteValue(Value); + ls2 := 0; + end; + // + Parts.Add(S); + end; + // + if (ls2 > 0) then + Parts.Add(S2 + QuoteValue(Value))// was not found... + ; + // + // Combine into string: + Header := CombineStrings(Parts, '; '); + // + finally + Parts.Free; + end; +end; + +function CombineStrings(Strings: TStrings; const Separator: string): string; +var + S: string; + i: integer; +begin + Result := ''; + for i := 0 to Strings.Count - 1 do + begin + S := Strings[i]; + if (i > 0) then + Result := Result + Separator + S + else + Result := Result + S; + end; +end; + +function SameHead(const Str, SHead: string): boolean; +begin + Result := SameText(Copy(Str, 1, Length(SHead)), SHead); +end; + +const + // SysUtils.ShortDayNames may be translated with resources... here use constants: + UsShortDayNames: array[1..7] of string = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); + UsShortMonthNames: array[1..12] of string = + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); + +function FormatHttpDate(LocalDate: TDateTime; bnIsLocal: boolean): string; +var + UtcDate: TDateTime; + d, m, y, h, n, s, z: word; +begin + if (LocalDate <= 1) then + begin + Result := ''; + exit; + end; + // This format is recomended by RFC2616. it MUST be in GMT time-zone... + // Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 + if bnIsLocal then + UtcDate := LocalToUtcDateTime(LocalDate) + else + UtcDate := LocalDate; + DecodeDate(UtcDate, y, m, d); + DecodeTime(UtcDate, h, n, s, z); + Result := Format('%s, %.2d %s %.4d %.2d:%.2d:%.2d GMT', [UsShortDayNames[DayOfWeek(UtcDate)], + d, UsShortMonthNames[m], y, h, n, s]); +end; + +function LocalToUtcDateTime(LocalDate: TDateTime): TDateTime; +begin + // UTC = local_time + bias + if (LocalDate <> 0) then + Result := LocalDate + TimeZoneBiasTime() + else + Result := 0; +end; + +function UtcToLocalDateTime(UtcDate: TDateTime): TDateTime; +begin + // local_time = UTC - bias + if (UtcDate <> 0) then + Result := UtcDate - TimeZoneBiasTime() + else + Result := 0; +end; + +const + cMinuteToDateTime = 1 / (24 * 60); + +{$undef WIN32FILETIME} +{$undef WIN32TZ} +{$ifdef MSWINDOWS} {$ifndef CIL} + +{$define WIN32TZ} +function TimeZoneBiasTime: TDateTime; +var + tzi: TTimeZoneInformation; + Bias: integer; +begin + case GetTimeZoneInformation(tzi) of + TIME_ZONE_ID_UNKNOWN: Bias := tzi.Bias; + TIME_ZONE_ID_STANDARD: Bias := tzi.Bias + tzi.StandardBias; + TIME_ZONE_ID_DAYLIGHT: Bias := tzi.Bias + tzi.DaylightBias; + else + Bias := 0; + end; + if (Bias <> 0) then + Result := Bias * cMinuteToDateTime + else + Result := 0; +end; + +{$define WIN32FILETIME} +function FileTimeToUtcDateTime(const FileTime: TFileTime): TDateTime; +var + Sys: TSystemTime; +begin + if FileTimeToSystemTime(FileTime, Sys) then + Result := EncodeDate(Sys.wYear, Sys.wMonth, Sys.wDay) + EncodeTime(Sys.wHour, Sys.wMinute, + Sys.wSecond, Sys.wMilliseconds) + else + Result := 0; +end; + +{$endif}{$endif} +// +{$ifndef WIN32TZ} // fallback for dotnet & linux: +//const +// cMinuteToDateTime=1/(24*60); + +function TimeZoneBiasTime: TDateTime; +begin + Result := SynaUtil.TimeZoneBias*cMinuteToDateTime; +end; +{$endif} + +function GetFileDateUtc(const FileName: string): TDateTime; +var + SR: TSearchRec; +begin + // This could work on linux also? + if (FindFirst(FileName, faAnyFile, SR) = 0) then + begin + FindClose(SR); + // + {$ifdef WIN32FILETIME}// WIN32 + // Here we have directly UTC date-time: + Result := FileTimeToUtcDateTime(SR.FindData.ftLastWriteTime); + {$else ->fallback} + Result:=LocalToUtcDateTime(FileDateToDateTime(SR.Time)); + {$endif} + end else + Result := 0; +end; + +function ParseShortMonthName(const Token: string): integer; +var + i: integer; +begin + for i := 1 to 12 do + if SameText(Token, UsShortMonthNames[i]) then + begin + Result := i; + exit; + end; + Result := 0; +end; + +function ParseHttpDate(Str: string; out DateTime: TDateTime): boolean; +var + Token: string; + Int, y, m, d, h, n, s, tzh, tzm, tokencount: integer; + TzOffset: double; +begin + DateTime := 0; + // This format is recomended by RFC2616. it MUST be in GMT time-zone... + // Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 + // These formats are also possible: + // Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 + // Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format + // Anyhow due to robustness we will parse +0000 and -0000 timezones also... + y := 0; + m := 0; + d := 0; + h := 0; + n := 0; + s := 0; + tokencount := 0; + TzOffset := 0; + while (Str <> '') do + begin + Token := FetchToken(Str, ' ', True); + if (Token = '') then + continue; + // + Inc(tokencount); + if (tokencount > 31) then + break; + // + Int := -1; + if (CharInSet(Token[1], ['0'..'9'])) then + Int := StrToIntDef(Token, -1); + // + case Length(Token) of + 1, 2: if (d = 0) and (Int > 0) then + d := Int;// Day... + + 3: if (m = 0) and (Int < 0) then + m := ParseShortMonthName(Token);// Sun, GMT, Nov + + 4: if (y = 0) and (Int >= 1900) and (Int <= 2200) then + y := Int;// 1999 + + 5: if (CharInSet(Token[1], ['-', '+'])) and (CharInSet(Token[2], ['0'..'2'])) then + begin + // +0200, -0200 + tzh := StrToIntDef(Copy(Token, 2, 2), -1); + tzm := StrToIntDef(Copy(Token, 4, 2), -1); + if (tzh >= 0) and (tzm >= 0) then + begin + TzOffset := (tzh * (1 / 24)) + (tzm * (1 / (24 * 60))); + if (Token[1] = '+') then + TzOffset := -TzOffset; + end; + end; + else + if (Pos(':', Token) > 0) then + begin + // Time... + h := StrToIntDef(FetchToken(Token, ':', True), 0); + n := StrToIntDef(FetchToken(Token, ':', True), 0); + s := StrToIntDef(FetchToken(Token, ':', True), 0); + end else + if (d = 0) and (Pos('-', Token) > 0) then + begin + // 06-Nov-94 + d := StrToIntDef(FetchToken(Token, '-', True), 0); + m := ParseShortMonthName(FetchToken(Token, '-', True)); + if (m <> 0) then + begin + y := StrToIntDef(Token, -1); + if (y >= 0) then + if (y > 50) then + Inc(y, 1900) + else + Inc(y, 2000); + end; + end; + end; + end; + // + if (m > 0) and (m <= 12) and (y >= 1900) and (d > 0) and (d <= MonthDays[IsLeapYear(y), m]) then + begin + // Valid date... + DateTime := EncodeDate(y, m, d); + // Check time: + if (h >= 0) and (h <= 23) and (n >= 0) and (n <= 59) and (s >= 0) and (s <= 59) then + DateTime := DateTime + EncodeTime(h, n, s, 0) + TzOffset; + Result := True; + end else + Result := False; +end; + + +{$ifdef MSWINDOWS} {$ifndef CIL} {$define LOCALUTF} {$endif}{$endif} + +{$ifdef LOCALUTF} +//For compatibility with Delphi5, use our and kernel functions... + + //U+00000000 - U+0000007F 0xxxxxxx + //U+00000080 - U+000007FF 110xxxxx 10xxxxxx + //U+00000800 - U+0000FFFF 1110xxxx 10xxxxxx 10xxxxxx + //U+00010000 - U+001FFFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + //U+00200000 - U+03FFFFFF 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + //U+04000000 - U+7FFFFFFF 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx + +function GetUtfCharLen(pc: PChar): integer; +var + b: byte; +begin + b := Ord(pc[0]); + case b and $C0 of + 0, $40: Result := 1; + $C0: case b and $30 of + $00, $10: if (Ord(pc[1]) and $C0 = $80) then + Result := 2 + else + Result := 0;// 2 bytes: + + $20: if (Ord(pc[1]) and $C0 = $80) and (Ord(pc[2]) and $C0 = $80) then + Result := 3 + else + Result := 0;// 3 bytes: + + else + Result := 0; + // Longer than UCS-2 (unicode >$FFFF) not supported... + end;// Start multi-byte: + + else + Result := 0; // illegal + end; +end; + +function IsUtf8(pc: PChar): boolean; +var + bn80: boolean; + Len: integer; +begin + bn80 := False; + while (pc^ <> #0) do + if (byte(pc^) and $80 <> 0) then + begin + bn80 := True; + Len := GetUtfCharLen(pc); + if (Len > 0) then + Inc(pc, Len) + else + begin + // illegal bytes... + Result := False; + exit; + end; + end else + Inc(pc); + Result := bn80; +end; + +function FromUtf8ToWin(const S: string): string; +var + WideBuf: PWideChar; + Len, WideLen: integer; +begin + Len := Length(S); + WideBuf := AllocMem(Len * 2 + 16); + try + WideLen := MultiByteToWideChar(CP_UTF8, 0, Pointer(S), Len, WideBuf, Len); + if (WideLen = 0) then + begin + Result := ''; + exit; + end; + SetString(Result, PChar(nil), WideLen); + Len := WideCharToMultiByte(0, 0, WideBuf, WideLen, Pointer(Result), WideLen, '@', nil); + if (Len < WideLen) then + SetLength(Result, WideLen); + finally + FreeMem(WideBuf); + end; +end; + +procedure TryDecodeUtf8(var Url: string); +begin + if IsUtf8(PChar(Url)) then + Url := FromUtf8ToWin(Url); +end; + +{$else ->Delphi7+} + +// For Delphi7+ can use function in pascal System unit... +procedure TryDecodeUtf8(var Url: string); +var S: string; +begin + S:=UTF8ToString(Url); // returns empty, if not valid Utf8... + if (S<>'') then + Url:=S; +end; +{$endif} + +function ValHex(const S: string; var Value: integer): boolean; +var + code: integer; +begin + Val('$' + S, Value, Code); + Result := Code = 0; +end; + +function ConvertUrlChars(Url: string): string; +var + p, len, code: integer; + bnUtf: boolean; + buff: ansistring; +begin + // convert 'Documents%20and%20Settings' to 'Documents and Settings' + // and A+B to A B + Url := Url.Replace('+', ' '); + p := Pos('%', Url); + if (p = 0) then + Exit(Url); + // + // Exit(TIdURI.URLDecode(Url)); + buff := ansistring(Url); + bnUtf := False; + len := Length(buff); + while (p <= len) do + begin + if (buff[p] = '%') then + if ValHex(Copy(string(buff), p + 1, 2), code) then + begin + Delete(buff, p + 1, 2); + Dec(len, 2); + buff[p] := ansichar(code); + if (code > $80) then + bnUtf := True; + end; + Inc(p); + end; + // + if bnUtf then + Result := UTF8ToString(RawByteString(buff)) + else + Result := string(buff); +end; + +{ THeaderList } + +function THeaderList.Add(const S: string): integer; +var + Index: integer; + Line: string; +begin + // No empty lines: + Line := S; + if (Line = '') then + Exit(-1); + // Check multi-line headers: + if (Line[1] <= ' ') then + begin + Index := Count - 1; + if (Index >= 0) then + begin + // Append to last line: + Strings[Index] := Strings[Index] + #13#10 + Line; // line includes leading blank... + Exit(Index); + end; + end; + // Common adjustment (trim and normalize arround ":") + AdjustHeaderLine(Line); + // + Result := inherited Add(Line); +end; + +procedure THeaderList.Insert(Index: integer; const S: string); +var + S2: string; +begin + S2 := S; + if (S2 <> '') then + begin + // Common adjustment (trim and normalize arround ":") + AdjustHeaderLine(S2); + // + inherited Insert(Index, S2); + end; +end; + +procedure THeaderList.Put(Index: integer; const S: string); +var + S2: string; +begin + S2 := S; + if (S2 <> '') then + begin + // Common adjustment (trim and normalize arround ":") + AdjustHeaderLine(S2); + // + inherited Put(Index, S2); + end; +end; + +procedure THeaderList.AddValue(const Name, Value: string); +var + S: string; +begin + if (Name <> '') and (Value <> '') then + begin + S := Name + ': ' + Value; + AdjustHeaderLine(S); + inherited Add(S); + end; +end; + +function THeaderList.IndexOfName(const Name: string): integer; +var + i, len: integer; + S: string; +begin + Result := -1; + len := Length(Name); + if (len > 0) then + for i := 0 to Count - 1 do + begin + S := Strings[i]; + if (Length(S) > len) and (S[len + 1] = ':') and SameHead(S, Name) //and SameText(Copy(S,1,len),Name) + then + begin + Result := i; + break;//exit; + end; + end; +end; + +function IsName(const Line, Name: string): boolean; +var + len: integer; +begin + len := Length(Name); + if (len > 0) and (Length(Line) > len) and (Line[len + 1] = ':') and SameHead(Line, Name) + //and SameText(Copy(Line,1,len),Name) + then + Result := True + else + Result := False; +end; + +procedure LStrDel(var S: string; Index, Count: integer); +begin + Delete(S, Index, Count); +end; + +// returns pos after quote... +function StrSkipQuoted(const S: string; pquote: integer): integer; +var + Q: char; + p, len: integer; +begin + p := pquote; + Q := S[p]; + Inc(p); + len := Length(S); + while (p <= len) do + if (S[p] = Q) then + begin + // Found... + Inc(p); + Exit(p); + end else + if (S[p] = '\') then + Inc(p, 2) + else + Inc(p); + Result := 0; +end; + +// seek next occurence after this pos: +function StrSeek(const S: string; C: char; StartPos: integer): integer; +var + p, len: integer; +begin + len := Length(S); + p := StartPos; + if (p <= 0) then + p := 1; + while (p <= len) do + begin + if (S[p] = C) then + Exit(p); + Inc(p); + end; + Result := len + 1; +end; + +// remove first comma-separated value +function FetchQSepValue(var Line: string; const Sep: string): string; +var + pcomma, pquote, p, len: integer; +begin + // values are separated by "," but there may be another such in quotes... + pcomma := Pos(Sep, Line); + if (pcomma = 0) then + begin + // whole line is last part: + Result := Trim(Line); + Line := ''; + Exit; + end; + // skip quoted content: + pquote := Pos('"', Line); + while (pquote > 0) and (pquote < pcomma) do + begin + // May be quoted, may have multiple quoted parts... + p := StrSkipQuoted(Line, pquote); + pquote := StrSeek(Line, '"', p); + pcomma := StrSeek(Line, Sep[1], p); + if (pcomma = 0) then + begin + // whole line is last part: + Result := Trim(Line); + Line := ''; + exit; + end; + end; + // Extract part: + Result := TrimCopy(Line, 1, pcomma - 1); + // Remove part, comma and spaces: + len := Length(Line); + p := pcomma; + while (p < len) and ((Line[p + 1] <= ' ') or (Line[p + 1] = Sep[1])) do + Inc(p); + Delete(Line, 1, p); +end; + +// according to RFC2616, comma-separated headers may be also duplicated... +procedure THeaderList.EnumHeaders(const Name: string; const Enum: THeaderEnum; const Sep: char; + LParam: NativeUInt = 0); +var + i, Index, Cnt: integer; + Line, Value: string; +begin + Index := IndexOfName(Name); + if (Index >= 0) then + begin + i := Index; + Line := Strings[i]; + while True do + begin + // Process this line: + LStrDel(Line, 1, Length(Name) + 2); // remove 'Name: ' + Line := Trim(Line); + // + while (Line <> '') do + begin + Value := FetchQSepValue(Line, Sep); + if (Value <> '') then + if Enum(Value, LParam) then + Exit; + end; + // find next... + Inc(i); + Cnt := Count; + while (i < Cnt) do + begin + Line := Strings[i]; + if IsName(Line, Name) then + break; + Inc(i); + end; + if (i >= Cnt) then + break; + end; + end; +end; + +{$ifndef CIL} +// Simple pascal: +type + PHeaderFinder = ^THeaderFinder; + + THeaderFinder = record + FindValue: PString; + Found: boolean; + end; + +{$else ->dotnet is more complicated} +type + THeaderFinder=class(TObject) + public + FindValue: string; + Found: Boolean; + function CheckHttpFindValue(const Value: string; LParam: Longint): Boolean; + end; + PHeaderFinder=THeaderFinder; + +function THeaderFinder.CheckHttpFindValue(const Value: string; LParam: Longint): Boolean; +var S: string; +begin + S:=Value; + if SameText(FetchToken(S,'=',True),FindValue) then begin + Found:=True; + Result:=True; // stop. + end else + Result:=False; // continue... +end; +{$endif} + +function THeaderList.CheckHttpFindValue(const Value: string; LParam: NativeUInt): boolean; +{$ifndef CIL} +var + S: string; + Finder: PHeaderFinder; +{$endif} +begin + {$ifndef CIL} + Finder := PHeaderFinder(LParam); + S := Value; + if SameText(FetchToken(S, '=', True), Finder.FindValue^) then + begin + Finder.Found := True; + Result := True; // stop. + end else + {$endif} + Result := False; // continue... +end; + +function THeaderList.HasValue(const Name, Value: string): boolean; +var + Finder: THeaderFinder; +begin + {$ifndef CIL} + // Simple: + Finder.FindValue := @Value; + Finder.Found := False; + // + EnumHeaders(Name, Self.CheckHttpFindValue, ',', NativeUInt(@Finder)); + Result := Finder.Found; + // + {$else ->dotnet, little more complicated} + // + Finder:=THeaderFinder.Create; + Finder.FindValue:=Value; + Finder.Found:=False; + EnumHeaders(Name,Finder.CheckHttpFindValue,0); + Result:=Finder.Found; + Finder.Free; + {$endif} +end; + +function THeaderList.GetValueByName(const Name: string): string; +var + Index, p: integer; +begin + Index := IndexOfName(Name); + if (Index >= 0) then + begin + //Result:=GetValueByIndex(Index); + Result := Strings[Index]; + //System.Delete(Result,Length(Name)+2); // remove 'Name: ' + p := Length(Name) + 2; + Result := Copy(Result, p + 1, Length(Result) - p); + end else + Result := ''; +end; + +procedure THeaderList.SetValueByName(const Name, Value: string); +var + Index: integer; + S: string; +begin + if (Name <> '') then + if (Value <> '') then + begin + Index := IndexOfName(Name); + S := Trim(Name) + ': ' + Trim(Value); + if (Index >= 0) then + inherited Put(Index, S) //Strings[Index]:=S + else + inherited Add(S); + end else + RemoveValue(Name); +end; + +function THeaderList.RemoveValue(const Name: string): boolean; +var + Index, Count: integer; +begin + Result := False; + Index := IndexOfName(Name); + if (Index >= 0) then + begin + Delete(Index); + Result := True; + // + // Remove all occurences: + Count := Self.Count; + while (Index < Count) do + if IsName(Strings[Index], Name) then + begin + Delete(Index); + Dec(Count); + end else + Inc(Index); + end; +end; + +function THeaderList.GetNameByIndex(Index: integer): string; +var + p: integer; +begin + Result := Strings[Index]; + p := Pos(':', Result); + if (p > 0) then + Result := Copy(Result, 1, p - 1) + else + Result := ''; +end; + +function THeaderList.GetValueByIndex(Index: integer): string; +var + p: integer; +begin + Result := Strings[Index]; + p := Pos(':', Result); + if (p > 0) then + begin + Inc(p); // remove space after colon also... + Result := TrimCopy(Result, p + 1, Length(Result) - p); + end; +end; + +function THeaderList.GetSubValue(const Name, SubName: string): string; +begin + Result := Values[Name]; + if (Result <> '') then + Result := GetHeaderSubValue(Result, SubName); +end; + +procedure THeaderList.SetSubValue(const Name, SubName, Value: string); +var + S: string; + Index: integer; +begin + Index := IndexOfName(Name); + if (Index >= 0) then + S := ValuesByIndex[Index]//Values[Name]; + else + S := ''; + // + if (S <> '') then + ReplaceHeaderSubValue(S, SubName, Value)// Replace in existing header: + else + S := Format('%s=%s', [SubName, QuoteValue(Value)]); + // + S := Trim(Name) + ': ' + Trim(S); + // + if (Index >= 0) then + inherited Put(Index, S) + else + inherited Add(S); +end; + +{ THttpRequest } + +constructor THttpRequest.Create; +begin + inherited Create; + FHeaders := THeaderList.Create; + FParams := TStringList.Create; + FCookies := THttpCookies.Create; +end; + +destructor THttpRequest.Destroy; +begin + FreeAndNil({FContentStream}FPostStream); + FreeAndNil(FHeaders); + FreeAndNil(FParams); + FreeAndNil(FCookies); + inherited; +end; + +procedure THttpRequest.Assign(Source: TPersistent); +var + Req: THttpRequest; + Lines: TStrings; + Temp2: TStringList; + i, Count: integer; + S: string; +begin + if (Source is THttpRequest) then + begin + Req := THttpRequest(Source); + FHeaders.Assign(Req.FHeaders); + FCookies.Assign(Req.FCookies); + FUrl := Req.FUrl; + FMethod := Req.FMethod; + FProtocol := Req.FProtocol; + FContent := Req.FContent; + //FContentStream := Req.FContentStream; + //Req.FContentStream := nil; // only 1 request may own the content stream... + FPostStream := Req.FPostStream; + Req.FPostStream := nil; // only 1 request may own the content stream... + FStatusCode := Req.FStatusCode; + FStatusMsg := Req.FStatusMsg; + FConnection := Req.FConnection; + FFlags := Req.FFlags; + end else + if (Source is TStrings) then + begin + Lines := TStrings(Source); + Temp2 := nil; + try + // Load headers: + Headers.Clear; + i := 0; + Count := Lines.Count; + while (i < Count) do + begin + S := Lines[i]; + if (S = '') then + begin + // End of headers... + Inc(i); + break; + end; + Headers.Add(S); + Inc(i); + end; + // + if (i < Count) then + begin + // Load content: + // It is usually much faster to copy strings to new list than to delete items from start... + Temp2 := TStringList.Create; + Temp2.Capacity := Count - i; + while (i < Count) do + begin + Temp2.Add(Lines[i]); + Inc(i); + end; + FreeAndNil(Temp2); + FContent := Temp2.Text; + end; + finally + FreeAndNil(Temp2); + end; + end else + inherited; +end; + +procedure THttpRequest.SetHeaders(Value: THeaderList); +begin + if (Value <> nil) then + FHeaders.Assign(Value) + else + FHeaders.Clear; +end; + +procedure THttpRequest.SetCookies(Value: THttpCookies); +begin + if (Value <> nil) then + FCookies.Assign(Value) + else + FCookies.Clear; +end; + +type + THttpStatusMsg = record + Code: integer; + Msg: string; + end; + +const + // status codes defined in RFC2616: + HttpStatusMsgs: array[0..39] of THttpStatusMsg = ( + // Common codes: + (Code: 200; Msg: 'OK'), + (Code: 403; Msg: 'Forbidden'), + (Code: 404; Msg: 'Not Found'), + (Code: 401; Msg: 'Unauthorized'), + (Code: 500; Msg: 'Internal Server Error'), + (Code: 302; Msg: 'Found'), // use this for redirection + (Code: 304; Msg: 'Not Modified'), + (Code: 206; Msg: 'Partial Content'), + // + (Code: 100; Msg: 'Continue'), + (Code: 101; Msg: 'Switching Protocols'), + (Code: 201; Msg: 'Created'), + (Code: 202; Msg: 'Accepted'), + (Code: 203; Msg: 'Non-Authoritative Information'), + (Code: 204; Msg: 'No Content'), + (Code: 205; Msg: 'Reset Content'), + (Code: 300; Msg: 'Multiple Choices'), //also possible for redirection... + (Code: 301; Msg: 'Moved Permanently'), //also possible for redirection... + (Code: 303; Msg: 'See Other'), //also possible for redirection... + (Code: 305; Msg: 'Use Proxy'), //also possible for redirection... + (Code: 307; Msg: 'Temporary Redirect'),//also possible for redirection... + (Code: 400; Msg: 'Bad Request'), + (Code: 402; Msg: 'Payment Required'), + (Code: 405; Msg: 'Method Not Allowed'), + (Code: 406; Msg: 'Not Acceptable'), + (Code: 407; Msg: 'Proxy Authentication Required'), + (Code: 408; Msg: 'Request Timeout'), + (Code: 409; Msg: 'Conflict'), + (Code: 410; Msg: 'Gone'), + (Code: 411; Msg: 'Length Required'), + (Code: 412; Msg: 'Precondition Failed'), + (Code: 413; Msg: 'Request Entity Too Large'), + (Code: 414; Msg: 'Request-URI Too Long'), + (Code: 415; Msg: 'Unsupported Media Type'), + (Code: 416; Msg: 'Requested Range Not Satisfiable'), + (Code: 417; Msg: 'Expectation Failed'), + (Code: 501; Msg: 'Not Implemented'), + (Code: 502; Msg: 'Bad Gateway'), + (Code: 503; Msg: 'Service Unavailable'), + (Code: 504; Msg: 'Gateway Timeout'), + (Code: 505; Msg: 'HTTP Version Not Supported') + ); + +procedure THttpRequest.SetStatusCode(Value: integer); +begin + FStatusCode := Value; + GetHttpStatusMsg(FStatusCode, FStatusMsg); +end; + +function GetHttpStatusMsg(StatusCode: integer; var StatusMsg: string): boolean; +var + i: integer; +begin + for i := Low(HttpStatusMsgs) to High(HttpStatusMsgs) do + if (HttpStatusMsgs[i].Code = StatusCode) then + begin + StatusMsg := HttpStatusMsgs[i].Msg; + Result := True; + exit; + end; + Result := False; +end; + +function THttpRequest.GetFlagBool(Index: integer): boolean; +var + Mask: integer; +begin + Mask := 1 shl Index; + Result := (FFlags and Mask <> 0); +end; + +procedure THttpRequest.SetFlagBool(Index: integer; Value: boolean); +var + Mask: integer; +begin + Mask := 1 shl Index; + if Value then + FFlags := FFlags or Mask + else + FFlags := FFlags and not Mask; +end; + +procedure THttpRequest.ApplyHeaders(bnIsServer: boolean); +var + S: string; + p: integer; +begin + if bnIsServer then + Cookies.LoadClientCookies(Headers) + else + Cookies.LoadServerCookies(Headers); + // + // Parse parameters in URL: + FParams.Clear; + p := Pos('?', Url); + if (p > 0) then + begin + S := Copy(Url, p + 1, Length(Url) - p); + while (S <> '') do + FParams.Add(ConvertUrlChars(Trim(FetchQSepValue(S, '&')))); + end; +end; + +{Sample from RFC1867: + +Content-type: multipart/form-data, boundary=AaB03x + +--AaB03x +content-disposition: form-data; name="field1" + +Joe Blow +--AaB03x +content-disposition: form-data; name="pics"; filename="file1.txt" +Content-Type: text/plain + + ... contents of file1.txt ... +--AaB03x-- +{} + +procedure THttpRequest.ParsePostFormData; +var + S: string; + //p: integer; +begin + if Content.StartsWith('--') then + EnumMultiPart(Content, Boundary, AddMultiPartFormItem) + else + begin + S := Content; + while (S <> '') do + FParams.Add(ConvertUrlChars(Trim(FetchQSepValue(S, '&')))); + end; +end; + +function THttpRequest.AddMultiPartFormItem(Headers: THeaderList; const FieldName, Content: string): boolean; +var + S: string; +begin + S := Headers.SubValues['Content-Disposition', 'filename']; + if (S <> '') then // will add FieldName=filename + else + S := Content// will add FieldName=Content + ; + // + if (FieldName <> '') then + FParams.Add(FieldName + '=' + S) + else + FParams.Add(S); + // + Result := False; // all... +end; + +type + TGetPostParamInfo = class(TObject) + public + ParamName: string; + ParamData: string; + bnFound: boolean; + function FindParamEnum(Headers: THeaderList; const FieldName, Content: string): boolean; + end; + +function TGetPostParamInfo.FindParamEnum(Headers: THeaderList; const FieldName, Content: string): boolean; +begin + if SameText(FieldName, ParamName) then + begin + ParamData := Content; + bnFound := True; + Result := True; // stop. + end else + Result := False; // continue... +end; + +function THttpRequest.GetPostFormParam(const ParamName: string; var ParamData: string): boolean; +var + Info: TGetPostParamInfo; +begin + Info := TGetPostParamInfo.Create; + try + Info.ParamName := ParamName; + Info.ParamData := ParamData; + EnumMultiPart(FContent, Boundary, Info.FindParamEnum); + ParamData := Info.ParamData; + Result := Info.bnFound; + finally + Info.Free; + end; +end; + +procedure EnumMultiPart(ContentData, Boundary: string; const Enum: TMultipartEnumCallback); + + function FetchLine(var Rest: string): string; + begin + Result := FetchToken(Rest, #13#10, False); + end; + +var + Line: string; + Headers: THeaderList; + p, lbound: integer; + bnTerm, bnPart: boolean; +begin + // cannot use TStringList, since it would damage binary parts (uploaded files)?! + // could consume leading part of ContentData, but it can be very slow on large uploads... well, dotnet is slow anyway... + // + if (Boundary = '') then + begin + // autodetect boundary: + while (ContentData <> '') do + begin + Line := FetchLine(ContentData); + if (Line <> '') and (Line[1] = '-') and (Line[2] = '-') then + begin + //Delete(Line,1,2); Boundary:='--'+Line; + Boundary := Line; // contains leading '--' + break; + end; + end; + end else + begin + // Seek leading boundary: + Insert('--', Boundary, 1); + while (ContentData <> '') do + begin + Line := FetchLine(ContentData); + if (Line = '') then + continue; + if (Line = Boundary) then + break; + if (Line = Boundary + '--') then + exit; + end; + end; + lbound := Length(Boundary); + // + Headers := THeaderList.Create; + try + while (ContentData <> '') do + begin + // Parse part headers: + Headers.Clear; + while (ContentData <> '') do + begin + Line := FetchLine(ContentData); + if (Line = '') then + break; + Headers.Add(Line); + end; + // Parse part body: + bnTerm := False; + bnPart := False; + p := 1; + while (p < Length(ContentData)) do + begin + if (ContentData[p] = #13) and (ContentData[p + 1] = #10) and (ContentData[p + 2] = '-') and + (ContentData[p + 3] = '-') and CharInSet(ContentData[p + 2 + lbound], [#13, '-']) and + CharInSet(ContentData[p + 3 + lbound], [#10, '-']) then + begin + Line := Copy(ContentData, p + 2, lbound); + if (Line = Boundary) then + begin + // End of part body here: + Line := Copy(ContentData, 1, p - 1); + Inc(p, 2); // skip #13#10 + Inc(p, lbound); // skip '--Boundary' + bnTerm := (ContentData[p] = '-'); + Inc(p, 2); // skip either #13#10 or '--' + Delete(ContentData, 1, p); + // + if Enum(Headers, Headers.SubValues['Content-Disposition', 'name'], Line) then + exit; + Line := ''; + // + bnPart := True; + break; + end; + end; + Inc(p); + end; + // + if bnTerm then // final boundary reached... + break; + if not bnPart then // input was incomplete, no boundary after data was found... + break; + end; + finally + Headers.Free; + end; +end; + +const + StrPropNames: array[0..19] of string = ( + 'Content-Type', // 0 + 'Content-Type', // 1 + 'Content-Disposition', // 2 + 'Content-Disposition', // 3 + 'Location', // 4 + 'Etag', // 5 + 'Host', // 6 + 'Referer', // 7 + 'User-Agent', // 8 + 'Vary', // 9 + 'WWW-Authenticate', //10 //!!!TODO + 'Authorization', //11 + 'Content-Type', //12 + 'Content-Encoding', //13 + 'Cache-control', //14 + 'Pragma', //15 + 'Server', //16 + 'Accept-Encoding', //17 + 'Content-Length', //18 + 'Transfer-Encoding' //19 + ); + +function THttpRequest.GetStrProp(Index: integer): string; +var + p: integer; +begin + Result := ''; + if (Index >= 0) and (Index <= High(StrPropNames)) then + begin + Result := Headers[StrPropNames[Index]]; + // + case Index of + 1: + begin + // BaseContentType... remove sub-type... + p := Pos(';', Result); + if (p > 0) then + Result := TrimCopy(Result, 1, p - 1); + end; + 3: Result := GetHeaderSubValue(Result, 'filename');// TargetFileName, extract it: + // Content-Disposition: attachment; filename="Filename" also works without the "attachment"... + 12: Result := GetHeaderSubValue(Result, 'boundary');// Boundary: + end; + end; +end; + +procedure THttpRequest.SetStrProp(Index: integer; const Value: string); +var + i: integer; +begin + if (Index >= 0) and (Index <= High(StrPropNames)) then + case Index of + 3: + Headers.SubValues[StrPropNames[Index], 'filename'] := Value;// TargetFileName: + // Content-Disposition: attachment; filename="Filename" also works without the "attachment"... + 12: + begin + // Boundary: + if (Headers.Values[StrPropNames[Index]] = '') then + Headers.Values[StrPropNames[Index]] := 'multipart/mixed'; + // + Headers.SubValues[StrPropNames[Index], 'boundary'] := Value; + end; + 18: + begin + i := 0; + if TryStrToInt(Value, i) and (i > 0) then + Headers[StrPropNames[Index]] := Value; + end + else + Headers[StrPropNames[Index]] := Value; + end; +end; + +const + DatePropNames: array[0..3] of string = ( + 'Date', + 'Last-Modified', + 'Last-Modified', + 'Expires' + ); + DatePropIsLocal: array[0..3] of boolean = ( + True, + True, + False, + False + ); + +procedure THttpRequest.SetCharSet(const Value: string); +begin + FCharSet := Value; + Headers.SubValues['Content-Type', 'charset'] := Value; +end; + +function THttpRequest.GetDateProp(Index: integer): TDateTime; +begin + if (Index >= 0) and (Index <= High(DatePropNames)) and ParseHttpDate(Headers[DatePropNames[Index]], Result) then + begin + if DatePropIsLocal[Index] then + Result := UtcToLocalDateTime(Result); + exit; + end; + // + Result := 0; +end; + +procedure THttpRequest.SetDateProp(Index: integer; const Value: TDateTime); +var + bnIsLocal: boolean; +begin + if (Index >= 0) and (Index <= High(DatePropNames)) then + begin + bnIsLocal := DatePropIsLocal[Index]; + Headers[DatePropNames[Index]] := FormatHttpDate(Value, bnIsLocal); + end; +end; + +procedure THttpRequest.ServeFile(const LocalFileName: string); +begin + FreeAndNil({FContentStream}FPostStream); + // + if FileExists(LocalFileName) then + begin + //LastModified:=GetFileDateUtc(LocalFileName); // LastModified property is in LOCAL time, converting to UTC! + Headers[DatePropNames[1]{'Last-Modified'}] := FormatHttpDate(GetFileDateUtc(LocalFileName), False); + // + //FreeAndNil(FContentStream); + {ContentStream}PostStream := TFileStream.Create(LocalFileName, fmOpenRead or fmShareDenyWrite); + // + ContentType := DetectContentType(LocalFileName); + // + StatusCode := 200; // OK + // + end else + begin + // File not found: + StatusCode := 404; // Not Found + // Give some message: + if (Error404Url <> '') then + Redirect(Error404Url) + else + if (Error404DocText <> '') then + begin + Content := Error404DocText; + ContentType := 'text/html'; + end else + begin + // Fallback: + Content := '404 - not found.'; + ContentType := 'text/plain'; + end; + end; +end; + +function DetectContentType(const FileName: string): string; +var + Ext: string; +begin + // By file extension: + Ext := ExtractFileExt(FileName); + Result := GetContentTypeByExt(Ext); + //if (Result <> '') then + // Exit; + // + // Auto-detect by contents? + // Not here... + //Result := ''; +end; + +var + ContentTypes: TStringList; + +procedure RegisterContentType(const Ext, ContentType: string); +var + S, Prev: string; + Index: integer; +begin + S := Ext + '=' + ContentType; + if (S[1] = '=') then + exit; + if (S[1] <> '.') then + Insert('.', S, 1); + // + // + Index := 0; + ContentTypes.Find(S, Index); + if (Index < ContentTypes.Count) then + begin + Prev := ContentTypes[Index]; + if SameText(FetchToken(Prev, '=', True), Ext) then + begin + ContentTypes[Index] := S; + S := '';//exit; + end; + end; + if (S <> '') then + ContentTypes.Add(S); +end; + +procedure RegisterInternalContentTypes; +begin + // register some basic content types... + // other get registered from configuration or from registry: + RegisterContentType('.htm', 'text/html'); + RegisterContentType('.html', 'text/html'); + RegisterContentType('.xml', 'text/xml'); + RegisterContentType('.json', 'application/json'); + RegisterContentType('.txt', 'text/plain'); + RegisterContentType('.jpg', 'image/jpeg'); + RegisterContentType('.gif', 'image/gif'); + RegisterContentType('.png', 'image/png'); + RegisterContentType('.css', 'text/css'); + RegisterContentType('.ico', 'image/x-icon'); + RegisterContentType('.bmp', 'image/bmp'); + RegisterContentType('.htc', 'text/x-component'); + RegisterContentType('.js', 'text/javascript'); +end; + +function GetContentTypeByExt(const Ext: string): string; +var + Index: integer; +begin + Result := ''; + ContentTypes.Find(Ext + '=', Index); + if (Index < ContentTypes.Count) then + begin + Result := ContentTypes[Index]; + if not SameText(FetchToken(Result, '=', True), Ext) then + Result := ''; + end; +end; + +{$ifdef MSWINDOWS} + // Win32 specific... + //[HKEY_CLASSES_ROOT\.xsl] + //@="xslfile" + //"Content Type"="text/xml" + +procedure RegisterContentTypesFromRegistry; +var + Key, SubKey: HKEY; + KeyIndex: integer; + CbName, CbData: DWORD; + KeyName, Value: string; +begin + KeyIndex := 0; + Key := HKEY_CLASSES_ROOT; + CbName := 128;//x080922: 16; + SetLength(KeyName, CbName); + while (RegEnumKeyEx(Key, KeyIndex, @KeyName[1], CbName, nil, nil, nil, nil) = 0) do + begin + SetLength(KeyName, CbName); + if (KeyName <> '') and (KeyName[1] = '.') and (RegOpenKeyEx(Key, PChar(KeyName), 0, KEY_READ, SubKey) = 0) then + begin + CbData := 64; + SetLength(Value, CbData + 8); + if (RegQueryValueEx(SubKey, 'Content Type', nil, nil, @Value[1], @CbData) = 0) and (Value <> '') then + begin + SetLength(Value, CbData); + RegisterContentType(KeyName, Value); + end; + RegCloseKey(SubKey); + end; + // + Inc(KeyIndex); + CbName := 128;//x080922: 16; + SetLength(KeyName, CbName); + end; +end; + +{$endif MSWINDOWS} + +procedure THttpRequest.Redirect(const aUrl: string); +begin + //StatusCode := 302; // there are other 30x codes, but some HTTP/1.0 browsers do not understand them and understand only 302... + Self.Location := aUrl; +end; + +// parse: 'GET /index.html HTTP/1.1' // used by server +procedure THttpRequest.ParseFirstRequestLine(Line: string); +var + p: integer; +begin + Self.FMethod := FetchToken(Line, ' ', True); // this trims Command... + p := Length(Line) - 7; + if (p > 0) and SameText(Copy(Line, p, 4), 'HTTP') then + begin + Self.FProtocol := Copy(Line, p, 8); + Self.FUrl := TrimCopy(Line, 1, p - 1); + end else + begin + Self.FUrl := FetchToken(Line, ' ', True); + Self.FProtocol := Line; + end; + p := Pos('?', Url) - 1; + if p > 0 then + FDocument := Copy(Url, 1, p) + else + FDocument := Url; +end; + +// parse: 'HTTP/1.1 200 OK' // used by client +procedure THttpRequest.ParseFirstResponseLine(Line: string); +begin + FProtocol := FetchToken(Line, ' ', True); + FStatusCode := StrToIntDef(FetchToken(Line, ' ', True), 0); + FStatusMsg := Line; +end; + +// format: 'HTTP/1.1 200 OK' // used by server +function THttpRequest.GetFirstResponseLine: string; +begin + if (FProtocol = '') then + FProtocol := 'HTTP/1.0'; + if (FStatusCode = 0) then + StatusCode := 500; // Internal server error - did not set StatusCode...? + // + Result := Format('%s %d %s', [FProtocol, StatusCode, StatusMsg]); +end; + +// format: 'GET /index.html HTTP/1.1' // used by client +function THttpRequest.GetFirstRequestLine: string; +begin + if (FMethod = '') then + FMethod := 'GET'; + if (FUrl = '') then + FUrl := '/'; + if (FProtocol = '') then + FProtocol := 'HTTP/1.0'; + // + Result := Format('%s %s %s', [FMethod, FUrl, FProtocol]); +end; + +function THttpRequest.MatchTag(Etags: string): boolean; +var + E: string; +begin + Result := False; + // If-Match header may specify more tags, comma-separated... + while (Etags <> '') do + begin + E := FetchQSepValue(Etags, ','); + if (E = '') then + continue; + if (E = '*') then + begin + Result := (Self.Etag <> ''); + break;//exit; + end; + if (E = Self.Etag) then + begin + Result := True; + break;//exit; + end; + end; +end; + +{ THttpCookies } + +constructor THttpCookies.Create; +begin + inherited Create(THttpCookie); +end; + +function THttpCookies.GetCommaText: string; +var + i: integer; +begin + Result := ''; + for i := 0 to Count - 1 do + Result := Result + Cookies[i].Name + '=' + Cookies[i].Value + ','; + System.Delete(Result, High(Result), 1); +end; + +function THttpCookies.GetCookieItem(Index: integer): THttpCookie; +begin + Result := THttpCookie(inherited Items[Index]); +end; + +function THttpCookies.GetValue(const Name: string): string; +var + Cookie: THttpCookie; +begin + Cookie := Find(Name); + if Assigned(Cookie) then + Result := Cookie.Value + else + Result := ''; +end; + +function THttpCookies.IndexOf(const Name: string): integer; +var + i: integer; +begin + for i := 0 to Count - 1 do + if SameText(Cookies[i].Name, Name) then + begin + Result := i; + exit; + end; + Result := -1; +end; + +function THttpCookies.Find(const Name: string): THttpCookie; +var + Index: integer; +begin + Index := IndexOf(Name); + if (Index >= 0) then + Result := Cookies[Index] + else + Result := nil; +end; + +procedure THttpCookies.LoadClientCookies(Headers: THeaderList); +begin + Clear; + Headers.EnumHeaders('Cookie', AddCookieValue, ';', 1); + //x: Headers.EnumHeaders('Cookie2',AddCookieValue,2); +end; + +procedure THttpCookies.SaveServerCookies(Headers: THeaderList; const DefaultDomain, DefaultPath: string); +var + i: integer; + Cookie: THttpCookie; +begin + Headers.RemoveValue('Set-Cookie'); + for i := 0 to Count - 1 do + begin + Cookie := Cookies[i]; + if (Cookie.Domain = '') then + Cookie.Domain := Copy(DefaultDomain, 1, Pos(':', DefaultDomain) - 1); + if (Cookie.Path = '') then + Cookie.Path := DefaultPath; + Headers.AddValue('Set-Cookie', Cookie.GetServerCookie); + end; +end; + +procedure THttpCookies.SetDefaultPath; +var + i: integer; +begin + for i := 0 to Count - 1 do + if Cookies[i].Path.IsEmpty then + Cookies[i].Path := '/'; +end; + +procedure THttpCookies.SetSameSite; +var + i: integer; +begin + for i := 0 to Count - 1 do + begin + Cookies[i].Secure := True; + Cookies[i].SameSite := True; + end; +end; + +procedure THttpCookies.SetValue(const Name, Value: string); +var + Cookie: THttpCookie; +begin + Cookie := Find(Name); + if Assigned(Cookie) then + Cookie.Value := Value + else + begin + Cookie := THttpCookie(Add); + Cookie.Name := Name; + Cookie.Value := Value; + end; +end; + +procedure THttpCookies.LoadServerCookies(Headers: THeaderList); +begin + Clear; + Headers.EnumHeaders('Set-Cookie', AddCookieValue, ',', 1); + Headers.EnumHeaders('Set-Cookie2', AddCookieValue, ',', 2); +end; + +procedure THttpCookies.SaveClientCookies(Headers: THeaderList; const Path: string); +var + i: integer; + Cookie: THttpCookie; +begin + Headers.RemoveValue('Cookie'); + for i := 0 to Count - 1 do + begin + Cookie := Cookies[i]; + if (Path = '') or Cookie.MatchPath(Path) then + Headers.AddValue('Cookie', Cookie.GetClientCookie); + end; +end; + +function THttpCookies.AddCookieValue(const Value: string; LParam: NativeUInt): boolean; +var + Cookie: THttpCookie; +begin + Cookie := THttpCookie.Create(nil); + if Cookie.ParseValue(Value, LParam) then + Cookie.Collection := Self + else + Cookie.Free; + // + Result := False; // all... +end; + +procedure THttpCookies.MergeCookies(Source: THttpCookies); +var + i: integer; + Src, Dst: THttpCookie; +begin + for i := 0 to Source.Count - 1 do + begin + Src := Source[i]; + Dst := Self.Find(Src.Name); + if (Dst = nil) then + Dst := THttpCookie.Create(nil); + Dst.Assign(Src); + Dst.Collection := Self; + end; +end; + +{ THttpCookie } + +procedure THttpCookie.Assign(Source: TPersistent); +begin + if (Source is THttpCookie) then + begin + FName := THttpCookie(Source).FName; + FValue := THttpCookie(Source).FValue; + FDomain := THttpCookie(Source).FDomain; + FPath := THttpCookie(Source).FPath; + FExpires := THttpCookie(Source).FExpires; + FSecure := THttpCookie(Source).FSecure; + FMaxAge := THttpCookie(Source).FMaxAge; + end else + inherited; +end; + +procedure THttpCookie.DeleteCookie; +begin + // RFC2109: + //Optional. The Max-Age attribute defines the lifetime of the + //cookie, in seconds. The delta-seconds value is a decimal non- + //negative integer. After delta-seconds seconds elapse, the client + //should discard the cookie. A value of zero means the cookie + //should be discarded immediately. + FMaxAge := '0'; +end; + +function QuoteValue(const Value: string): string; +var + p, len: integer; +begin + Result := Value; + // + len := Length(Result); + p := 1; + while (p <= len) do + begin + case Result[p] of + '"', '\': + begin + Insert('\', Result, p); + Inc(p); + Inc(len); + end; + end; + Inc(p); + end; + // + Result := '"' + Result + '"'; +end; + +function NeedsCookieValueQuoting(const S: string): boolean; +var + p: integer; +begin + if (S = '') then + begin + Result := True; + exit; + end; + // + p := Length(S); + while (p > 0) do + begin + case S[p] of + '"', '=', ';', ',', #1..' ': + begin + Result := True; + exit; + end; + end; + Dec(p); + end; + Result := False; +end; + +function AddCookieProp(const Cookie, Name, Value: string; bnQuoted: boolean): string; +var + Sep, QVal: string; +begin + Result := Cookie; + if (Value <> '') then + begin + Sep := ''; + if (Result <> '') then + Sep := '; '; + // + QVal := Value; + // values may be quoted, but do not need to be quoted... + if bnQuoted and NeedsCookieValueQuoting(Value) then + QVal := QuoteValue(Value); + // + Result := Result + Sep + Name + '=' + QVal; + end; +end; + +function THttpCookie.GetServerCookie: string; // Set-Cookie: format... (for sending server->client) +begin + Result := AddCookieProp('', FName, FValue, True); + Result := AddCookieProp(Result, 'Version', FVersion, True); + Result := AddCookieProp(Result, 'Path', FPath, True); + Result := AddCookieProp(Result, 'Domain', FDomain, True); + Result := AddCookieProp(Result, 'Max-Age', FMaxAge, True); + Result := AddCookieProp(Result, 'Comment', FComment, True); + if FSameSite then + Result := AddCookieProp(Result, 'SameSite', 'none', False); + // + //Expires= is in this format: Wdy, DD-Mon-YY HH:MM:SS GMT + //in Netscape format, also must not use quotes or spaces elsewhere than in Expires... + // + if FSecure then + Result := Result + '; secure'; + if FValue = '' then + Result := FName + '=;' + Result; +end; + +function THttpCookie.GetText: string; +begin + Result := FName + '=' + ConvertUrlChars(FValue.Replace('\', '')); +end; + +function THttpCookie.GetClientCookie: string; // Cookie: format... (for sending client->server) +begin + if (Version <> '') then + Result := + AddCookieProp(AddCookieProp(AddCookieProp(AddCookieProp('', '$Version', Version, True), FName, FValue, True), + '$Path', FPath, True), '$Domain', FDomain, True)// RFC2109 format... should have Version='1' + // Cookie: $Version="1"; Name="Value"; $Path="Path", $Domain="Domain" + else + Result := AddCookieProp('', FName, FValue, False)// Simple Netscape format, just Name=Value, no quoting + //Result:=FName+'='+FValue; + ; +end; + +function THttpCookie.ParseValue(Line: string; Version: NativeUInt): boolean; +var + Value, Name: string; + bnFirst, bnSpecial: boolean; +begin + bnFirst := True; + while (Line <> '') do + begin + Value := FetchQSepValue(Line, ';'); + if (Value <> '') then + begin + Name := FetchToken(Value, '=', True); + // + if (Name <> '') and (Name[1] = '$') then + begin + bnSpecial := True; + Delete(Name, 1, 1); + end else + bnSpecial := False; + // + if bnFirst and not bnSpecial then + begin + FName := Name; + FValue := Value; + bnFirst := False; + end else if SameText(Name, 'path') then // do not localize... + FPath := Value + else + if SameText(Name, 'expires') then + FExpires := Value + else + if SameText(Name, 'domain') then + FDomain := Value + else + if SameText(Name, 'secure') then + FSecure := True + else + if SameText(Name, 'version') then + FVersion := Value// other values: + ; + end; + end; + Result := not bnFirst; +end; + +function THttpCookie.MatchPath(const aPath: string): boolean; +var + Len: integer; +begin + Len := Length(Self.Path); + // + if (Length(aPath) >= Len) and SameHead(aPath, Self.Path) //and SameText(Copy(aPath,1,Len),Self.Path) + then + Result := True + else + Result := False; +end; + +{ TSynHttpServer } + +constructor TSynHttpServer.Create(AOwner: TComponent); +begin + inherited; + Port := '80'; + // + //FConnClass:=TSynTcpSrvConnection; // we are using generic connection class... + // + if not (csDesigning in ComponentState) then + OnCommand := HandleClientCommand; +end; + +procedure TSynHttpServer.SetActive(Value: boolean); +begin + {$ifdef DEBUG} + if (Value=Self.Active) then + exit; + if Value then + Debug('%s http server on port %s',['Starting',Port]) + else + Debug('%s http server on port %s',['Stoping',Port]); + {$endif DEBUG} + // + inherited; + // + {$ifdef DEBUG} + Debug('Done.'); + {$endif DEBUG} +end; + +(*function GetStreamSize(Stream: TStream): int64; +var + Pos: int64; +begin + Pos := Stream.Position; + Result := Stream.Size; + // + {$ifdef MSWINDOWS} + // Workarround for Delphi 5, where stream does not return Int64... + if (Stream is TFileStream) then begin + LARGE_INTEGER(Pos).HighPart:=0; + LARGE_INTEGER(Pos).LowPart:=SetFilePointer(TFileStream(Stream).Handle,0,@LARGE_INTEGER(Pos).HighPart,FILE_CURRENT); + LARGE_INTEGER(Result).HighPart:=0; + LARGE_INTEGER(Result).LowPart:=SetFilePointer(TFileStream(Stream).Handle,0,@LARGE_INTEGER(Result).HighPart,FILE_END); + // + SetFilePointer(TFileStream(Stream).Handle,LARGE_INTEGER(Pos).LowPart,@LARGE_INTEGER(Pos).HighPart,FILE_BEGIN); + end; + {$endif} + // + Result := Result - Pos; +end; + +procedure StreamSeek(Stream: TStream; Offset: int64); +var + This: longint; +begin + // Workarround for Delphi 5, where TStream cannot seek by Int64... + while (Offset > 0) do + begin + if (Offset < $20000000) then + This := Offset + else + This := $20000000; + Dec(Offset, This); + Stream.Seek(This, soFromCurrent); + end; +end;*) + +function ParseRangeRequest(S: string; var RangeStart, RangeLength: int64; const ContentSize: int64; + bnSizeKnown: boolean): boolean; +var + p: integer; + S1, S2: string; + RangeEnd: int64; +begin + Result := False; + // bytes=0-1000 + // bytes=1000- + // bytes=-1000 + // bytes=0-1000,2000-3000 this form is not parsed here and is ignored... this way we can avoid sending multipart/byte-ranges response... + // + if SameHead(S, 'bytes') //if SameText(Copy(S,1,5),'bytes') + then + begin + Delete(S, 1, 5); + DoTrim(S); // can have space: bytes = ... + if (S <> '') and (S[1] = '=') then + begin + Delete(S, 1, 1); + DoTrim(S); + end; + // + p := Pos('-', S); + if (p = 0) then + exit; + // + S1 := TrimCopy(S, 1, p - 1); + S2 := TrimCopy(S, p + 1, 63); + // + RangeStart := StrToInt64Def(S1, -1); + RangeEnd := StrToInt64Def(S2, -1); + // + if (S1 = '') then + begin + if (S2 = '') or not bnSizeKnown or (RangeEnd < 0) then + exit; + // bytes=-tailsize + RangeStart := ContentSize - RangeEnd; + RangeLength := RangeEnd; + Result := True; + end else + if (S2 = '') then + begin + // bytes=startpos- + if (RangeStart < 0) or not bnSizeKnown then + exit; + RangeLength := ContentSize - RangeStart; + Result := True; + end else + if (RangeStart >= 0) and (RangeEnd >= 0) then + begin + // bytes=startpos-endpos + RangeLength := RangeEnd - RangeStart + 1; + Result := True; + end; + end; +end; + +// this function is the body of http request handling: +procedure TSynHttpServer.HandleClientCommand(Connection: TSynTcpSrvConnection; Command: string); +var + Request, Reply: THttpRequest; +begin + // Command is first line of request: GET /index.html HTTP/1.1 + Request := THttpRequest.Create; + Reply := THttpRequest.Create; + try + ReadRequest(Connection, Request, Reply, Command); + DoHttpGet(Connection, Request, Reply); + //------------------------------------------------------------------------- + // Pass to application: + if (Reply = nil) then + Exit;// There is a chance for application to send reply, free it and give us NIL instead, to prevent further processing... + //------------------------------------------------------------------------- + SendReply(Connection, Request, Reply); + // + finally + Reply.Free; + Request.Free; + end; +end; + +procedure TSynHttpServer.CreatePostStream(Request: THttpRequest); +begin + if Assigned(OnCreatePostStream) then + OnCreatePostStream(Self, Request, Request.FPostStream); +end; + +procedure TSynHttpServer.ReadRequest(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest; Command: string); +var + bnContinue, bnHttp11: boolean; + S: string; + + function PreparePostStream: boolean; + var + i, Size: integer; + begin + Result := False; + if (Request.TransferEncoding <> '') and (not SameText(Request.TransferEncoding, 'identity')) then + begin + if Pos('chunked', LowerCase(Request.TransferEncoding)) = 0 then + begin + Reply.StatusCode := 400; // bad request + //Reply.WriteHeader; + Connection.Terminate; + Exit; + end; + CreatePostStream(Request); + if Request.FPostStream = nil then + Request.FPostStream := TMemoryStream.Create; + Request.PostStream.Position := 0; + repeat + S := string(Connection.Socket.RecvString(cDefLineTimeout)); + if (Connection.Socket.LastError <> 0) then + Exit; + i := Pos(';', S); {do not localize} + if i > 0 then + S := Copy(S, 1, i - 1); + Size := StrToIntDef('$' + Trim(S), 0); {do not localize} + if Size = 0 then + Break; + Connection.Socket.RecvStreamSize(Request.PostStream, cDefLineTimeout, Size); + Connection.Socket.RecvString(cDefLineTimeout); // CRLF at end of chunk data + until False; + // skip trailer headers + repeat + until Connection.Socket.RecvString(cDefLineTimeout) = ''; + Request.PostStream.Position := 0; + end + else if Request.ContentLength <> '' then + begin + CreatePostStream(Request); + if Request.FPostStream = nil then + Request.FPostStream := TMemoryStream.Create; + Request.PostStream.Position := 0; + if Request.ContentLength > '0' then + begin + Size := StrToIntDef(Request.ContentLength, 0); + Connection.Socket.RecvStreamSize(Request.PostStream, cDefLineTimeout, Size); + Request.PostStream.Position := 0; + end; + end + // If HTTP Pipelining is used by the client, bytes may exist that belong to + // the NEXT request! We need to look at the CURRENT request and only check + // for misreported body data if a body is actually expected. GET and HEAD + // requests do not have bodies... + else if SameText(Request.Method, 'POST') or SameText(Request.Method, 'PUT') then + begin + // TODO: need to handle the case where the ContentType is 'multipart/...', + // which is self-terminating and does not strictly require the above headers... + if Connection.Socket.LineBuffer = '' then + Connection.Socket.CanReadEx(cDefLineTimeout); + if Connection.Socket.LineBuffer <> '' then + begin + Reply.StatusCode := 411; // length required + Connection.Terminate; + Exit; + end; + end; + Result := True; + end; + +begin + // + // Connect objects: + Request.FConnection := Connection; + Reply.FConnection := Connection; + // + // Parse first line: + {$ifdef DEBUG} Debug('Command:'#13#10'%s',[Command]); {$endif} + Request.ParseFirstRequestLine(Command); + // + // Read rest of headers: + if not ReadHeadersFromSocket(Connection.Socket, Request.Headers, + {Connection.Socket.GetRecvTimeout}cDefLineTimeout) then + begin + Connection.Terminate; + Exit; + end; + Request.ApplyHeaders(True); + // + if (Request.Protocol >= 'HTTP/1.1') and SameHead(Request.Protocol, 'HTTP') + //and SameText(Copy(Request.Protocol,1,4),'HTTP') + then + begin + bnHttp11 := True; + Reply.FProtocol := 'HTTP/1.1'; // we are compliant... + // + S := Request.Headers['Expect']; + if (S <> '') then + begin + // RFC2616: + //A server that does not understand or is unable to comply with any of + //the expectation values in the Expect field of a request MUST respond + //with appropriate error status. The server MUST respond with a 417 + //(Expectation Failed) status if any of the expectations cannot be met + //or, if there are other problems with the request, some other 4xx + //status. + bnContinue := SameText(S, '100-continue'); // we understand only this Expect value... + if Assigned(FOnExpect) then + FOnExpect(Self, Request, bnContinue); + // + if bnContinue then + begin + Reply.StatusCode := 100; // 100 continue + Connection.Socket.SendString(UTF8Encode(Reply.GetFirstResponseLine + #13#10#13#10)); + end else + begin + // RFC2616: + //If it responds with a final status + //code, it MAY close the transport connection + Reply.StatusCode := 417; // Expectation failed + Connection.Socket.SendString(UTF8Encode(Reply.GetFirstResponseLine + #13#10#13#10)); + Connection.Terminate; + Exit; + end; + end; + end else + if (Request.Protocol = 'HTTP/1.0') then + begin + Reply.FProtocol := 'HTTP/1.0'; + bnHttp11 := False; + end else + begin + // Do not serve just any non-sense, written to our port... + // Chance for getting HTTP/0.9 request is very small, + // but chance for getting for ex. SMTP communication into the server port is much better... + Connection.Terminate; + Exit; + end; + // + // Read body: + if not PreparePostStream then + Exit; + if Assigned(Request.PostStream) and SameText(Request.Method, 'POST') then + begin + S := Request.ContentType; + if S.StartsWith('application/x-www-form-urlencoded', True) {or S.StartsWith('multipart/form-data', True)} then + with TStringStream.Create do + begin + CopyFrom(Request.PostStream, Request.PostStream.Size); + Request.FContent := DataString; + Free; + end; + end; + // + // Set some defaults: + Reply.StatusCode := 404; // default to Not-found... + if bnHttp11 then + begin + // HTTP/1.1 clients should default to keep-alive (rfc2616): + if not Request.Headers.HasValue('Connection', 'close') then + Reply.Headers['Connection'] := 'keep-alive' + else + Reply.Headers['Connection'] := 'close'; + end else if Request.Headers.HasValue('Connection', 'keep-alive') then + Reply.Headers['Connection'] := 'keep-alive' + else + Reply.Headers['Connection'] := 'close'// HTTP/1.0 clients should default to close (rfc2616): + ; + // + // Cookies: + //??? Reply.Cookies.Assign(Request.Cookies); + // + // POST parameters: + if Request.FContent <> '' then + Request.ParsePostFormData; + // + Reply.Headers['Server'] := ServerValue; +end; + +procedure TSynHttpServer.DoHttpGet(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); +begin + if Assigned(FOnHttpGet) then + FOnHttpGet(Self, Connection, Request, Reply); +end; + +function IsWithin(Value, Min, Max: integer): boolean; +begin + Result := (Value >= Min) and (Value <= Max); +end; + +function ExtractUrlPath(const Url: string): string; +var + p: integer; + bnFound: boolean; +begin + Result := Url; + p := Pos('://', Result); + if (p > 0) then + begin + Delete(Result, 1, p + 2); // remove http:// + p := Pos('/', Result); + if (p > 0) then + Delete(Result, 1, p); // remove hostname + end; + // + p := Pos('?', Result); + if (p = 0) then + p := Length(Result) + 1; + bnFound := False; + while (p > 1) do + begin + Dec(p); + if (Result[p] = '/') then + begin + SetLength(Result, p - 1); + bnFound := True; + break; + end; + end; + // + if not bnFound or (Result = '') then + Result := '/'; +end; + +procedure TSynHttpServer.SendReply(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); +var + bnBody, bnSize: boolean; + S: string; + Size, RangeStart, RangeLength: int64; + Date, Date2: TDateTime; + + function AlwaysUpdate(const Url: string): boolean; + begin + Result := (Url = '/') or (Url.ToLower.Contains('.html')); + end; + +begin + if Reply.ResponseSent then + Exit; + // Adjust Reply: + // + // Cookies: + Reply.Cookies.SetDefaultPath; + if FHTTPSEnabled then + Reply.Cookies.SetSameSite; + Reply.Cookies.SaveServerCookies(Reply.Headers, Request.Host, ExtractUrlPath(Request.Url)); + // + // Fill other values: + if (Reply.Headers['Date'] = '') then + Reply.Headers['Date'] := FormatHttpDate(Now, True); + // + // Content-Length and Transfer-Encoding: + if Reply.SendChunked then + begin + Reply.ContentLength := ''; + Reply.TransferEncoding := 'chunked'; + Size := -1; + bnSize := False; + end else + begin + S := Reply.ContentLength; + if (S = '') then + begin + // Fill Content-Length: + if (Reply.PostStream <> nil) then + begin + //Size:=Reply.ContentStream.Size; + Size := Reply.PostStream.Size; + bnSize := True; + end else + if (Reply.Content <> '') then + begin + Size := Length(UTF8Encode(Reply.Content)); + bnSize := True; + end else + begin + Size := 0; + bnSize := False; + end; + // + Reply.ContentLength := IntToStr(Size); + // + end else + begin + // Content-Length was filled by application: + Size := StrToInt64Def(S, -1); + bnSize := (Size >= 0); + end; + end; + // + //? if (Reply.StatusCode=404) then Reply.Headers['Connection']:='close'; + // + if IsWithin(Reply.StatusCode, 200, 299) and not AlwaysUpdate(Request.Url) then + begin + // + // Check If-Modified-Since: + S := Request.Headers['If-Modified-Since']; + if (S <> '') and ParseHttpDate(S, Date) then + begin + {$ifdef DEBUG} + Debug('If-Modified-Since: %s',[S]); + Debug('Last-Modified: %s',[Reply.Headers['Last-Modified']]); + {$endif DEBUG} + // + Date2 := Reply.LastModifiedUtc; + if (Date2 <> 0) and (Date2 > Date) then // is modified... +{$ifdef DEBUG} +{$endif DEBUG} + else + begin + // Is not modified... + Reply.StatusCode := 304; // Not Modified + //!!!TODO/bug + // mozilla hangs in transfer, when it gets the 304 responses?? + //if (Copy(Request.Headers['User-Agent'], 1, 7) = 'Mozilla') then + // Reply.Headers['Connection'] := 'close'; + end; + end else + begin + {$ifdef DEBUG} + if (S<>'') then + Debug('Failed parse date "%s"',[S]); + {$endif DEBUG} + // + S := Request.Headers['If-Unmodified-Since']; + if (S <> '') and ParseHttpDate(S, Date) then + begin + Date2 := Reply.LastModifiedUtc; + if (Date2 <> 0) and (Date2 > Date) then + Reply.StatusCode := 412// is modified + // Precondition Failed + ; + end; + end; + end; + // + if IsWithin(Reply.StatusCode, 200, 299) then + begin + // + // Check If-Range - if the condition fails, we will ignore Range: header... + S := Request.Headers['If-Range']; + if (S <> '') then + if (CharInSet(S[1], ['w', 'W'])) and (S[2] = '/') // W/"tag" + or (S[1] = '"') // "tag" + then + begin + if not Request.Headers.HasValue('Etag', S) then + Request.Headers['Range'] := ''; // does not have this Etag... + end else if ParseHttpDate(S, Date) then + begin + Date2 := Reply.LastModifiedUtc; + if (Date2 = 0) or (Date2 <= Date) then // is not modified since... + else + begin + // was modified since... + Request.Headers['Range'] := ''; // will send whole... + end; + end else + Request.Headers['Range'] := ''// Http-date: like If-Unmodified-Since... + // we do not understand If-Range header, so we will send whole body... + // If-Range = "If-Range" ":" ( entity-tag | HTTP-date ) + ; + // + // Check Range: header + RangeStart := 0; + RangeLength := 0; + S := Request.Headers['Range']; + if (S <> '') and ParseRangeRequest(S, RangeStart, RangeLength, Size, bnSize) then + if (bnSize and (RangeStart >= Size)) or (RangeLength <= 0) then + begin + Reply.StatusCode := 416; // Requested Range Not Satisfiable + Reply.ContentLength := ''; + if bnSize then + Reply.Headers['Content-Range'] := Format('*/%d', [Size]); // we SHOULD send this with 416 code... + Size := 0; // do not send body... //we will not send body, filtered also below... + end else + begin + // Valid range: + if bnSize then + S := IntToStr(Size) + else + S := '*'; + Reply.StatusCode := 206; // Partial Content + Reply.Headers['Content-Range'] := + Format('bytes %d-%d/%s', [RangeStart, RangeStart + RangeLength - 1, S]); + if bnSize then + Reply.ContentLength := IntToStr(RangeLength); + // + if (RangeStart <> 0) then + if (Reply.PostStream <> nil) then + Reply.PostStream.Seek(RangeStart, soCurrent) + else + if (Reply.Content <> '') then + Delete(Reply.FContent, 1, RangeStart); + // + if (RangeLength <> 0) then + begin + Size := RangeLength; + if (Reply.PostStream = nil) and (Reply.Content <> '') and (Size < Length(Reply.Content)) then + SetLength(Reply.FContent, Size); + end; + end// + ; + end; + // + if IsWithin(Reply.StatusCode, 200, 299) then + begin + // Check Etag headers (If-Match, If-None-Match) + S := Request.Headers['If-Match']; + if (S <> '') then + if not Reply.MatchTag(S) then + Reply.StatusCode := 412// Precondition Failed + // reply may have more tags, comma-separated, some week... + // also If-Match may specify more tags... + ; + S := Request.Headers['If-None-Match']; + if (S <> '') then + if Reply.MatchTag(S) then + Reply.StatusCode := 412// Precondition Failed + ; + end; + // + //------------------------------------------------------------------------- + // Write reply to client: + S := Reply.GetFirstResponseLine + #13#10 + Reply.Headers.Text + #13#10; // include 1 empty line after headers... + {$ifdef DEBUG}Debug('Response headers:'#13#10'%s',[S]);{$endif} + Connection.Socket.SendString(UTF8Encode(S)); + Reply.ResponseSent := True; + if (Connection.Socket.LastError <> 0) then + begin + Connection.Terminate; + Exit; + end; + // + bnBody := True; + if SameText(Request.Method, 'HEAD') then + bnBody := False // MUST NOT send entity body with HEAD, but should send Content-Length... + else + case Reply.StatusCode of + 412, // this is not in RFC, but we will not send entity body with 412 precondition failed anyway... + 416, // this is not in RFC, but we will not send entity body with 416 code (Requested Range Not Satisfiable) anyway... + 100..199, 204, 304: + begin + bnBody := False; // we MUST NOT send entity body with these status-codes... + // Do not send Content-Length and Content-Type fields + Reply.Headers['Content-Length'] := ''; + Reply.Headers['Content-Type'] := ''; + end; + end; + // + if bnBody then + begin + // Send body: + if (Reply.PostStream <> nil) then + SendSocketStream(Connection.Socket, Reply.PostStream, Size, Reply.SendChunked) + //x: we cannot use this, since it uses Stream.Size: Connection.Socket.SendStreamRaw(Reply.ContentStream); + else + if (Reply.Content <> '') then + if not Reply.SendChunked then + Connection.Socket.SendString(UTF8Encode(Reply.Content)) + else + begin + // Send 1 chunk: + Connection.Socket.SendString(UTF8Encode(Format('%x'#13#10, [Length(Reply.Content)]))); + if (Connection.Socket.LastError = 0) then + Connection.Socket.SendString(UTF8Encode(Reply.Content)); + if (Connection.Socket.LastError = 0) then + Connection.Socket.SendString('0'#13#10#13#10); + end; + // + if (Connection.Socket.LastError <> 0) then + begin + Connection.Terminate; + exit; + end; + end; + // + if Reply.Headers.HasValue('Connection', 'close') then + Connection.Terminate; +end; + +procedure TSynHttpServer.InitHttps(const CertFile, KeyFile, KeyPassword, CaCertFile: string); +begin + if not FileExists(CertFile) or not FileExists(KeyFile) then + Exit; + FCertFile := CertFile; + FKeyFile := KeyFile; + FKeyPass := KeyPassword; + FCaCertFile := CaCertFile; + //FSynapseServer.Socket.SSL.CertCAFile := ExtractFilePath(ParamStr(0)) + 's_cabundle.pem'; + FSynapseServer.Socket.SSL.CertificateFile := FCertFile; + FSynapseServer.Socket.SSL.PrivateKeyFile := FKeyFile; + FSynapseServer.Socket.SSL.KeyPassword := FKeyPass; + FSynapseServer.Socket.SSL.VerifyCert := True; + // + //if (Self.Port = '80') then + //Self.Port := '443'; +end; + +initialization + ContentTypes := TStringList.Create; + ContentTypes.Sorted := True; + RegisterInternalContentTypes; + +finalization + FreeAndNil(ContentTypes); +end. diff --git a/SynSrv.pas b/SynSrv.pas new file mode 100644 index 0000000..7cd55aa --- /dev/null +++ b/SynSrv.pas @@ -0,0 +1,317 @@ +{--------------------------------------------------------------} +{ } +{ SynSrv.pas - generic TCP server over Synapse library } +{ } +{ Author: Semi } +{ Started: 070528 } +{ } +{--------------------------------------------------------------} +unit SynSrv; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +interface + +uses + SysUtils, + Classes, + synsock, + blcksock, + Generics.Collections; +//------------------------------------------------------------- + +const + // Default timeout to receive 1 line from connection: + cDefLineTimeout = 120000; // default 2 minutes... + +type + TSynTcpSrvConnection = class; + TSynTcpServer = class; + + { TListenerThread } + + TListenerThread = class(TThread) + private + FThreadList: TObjectList; + FSocket: TTCPBlockSocket; + FPort: string; + FHost: string; + FTcpServer: TSynTcpServer; + procedure ClearFinishedThreads; + procedure BindSocket; + protected + procedure Execute; override; + public + constructor Create(ASuspended: boolean; ATcpServer: TSynTcpServer); + destructor Destroy; override; + property Host: string Read FHost Write FHost; + property Port: string Read FPort Write FPort; + property Socket: TTCPBlockSocket Read FSocket; + end; + + TSynTcpSrvConnection = class(TThread) + private + FTcpServer: TSynTcpServer; + FFinished: boolean; + FSocket: TTCPBlockSocket; + function GetClientAddress: string; + function GetClientPort: integer; + protected + procedure Execute; override; + public + destructor Destroy; override; + constructor Create(ASuspended: boolean; ASocket: TSocket; ATcpServer: TSynTcpServer); + property Socket: TTCPBlockSocket Read FSocket Write FSocket; // client socket + property ClientAddress: string Read GetClientAddress; // '123.45.67.89' + property ClientPort: integer Read GetClientPort; + end; + + TCommandHandler = procedure(Connection: TSynTcpSrvConnection; Command: string) of object; + + // TSynTcpServer - Generic TCP server component + TSynTcpServer = class(TComponent) + protected + FActive: boolean; + FPort: string; + FHost: string; + FHTTPSEnabled: boolean; + // + FOnCommand: TCommandHandler; + // + FSynapseServer: TListenerThread; + procedure SetPort(const Value: string); + procedure SetLocalAddr(const Value: string); + procedure SetActive(Value: boolean); virtual; + public + constructor Create(AOwner: TComponent); override; + // + // + published + // Host may be assigned to 'localhost' to serve only on localhost interface... + property Host: string Read FHost Write FHost; + // + // Port must be assigned. + property Port: string Read FPort Write SetPort; // MUST assign port... + // + // Set Active:=True to start server, set Active:=False to stop server + property Active: boolean Read FActive Write SetActive default False; + // + // Or assign OnCommand to parse commands (text lines) from connection: + // (this is used by TSynHttpServer and TSynFtpServer etc...) + property OnCommand: TCommandHandler Read FOnCommand Write FOnCommand; + property HTTPSEnabled: boolean Read FHTTPSEnabled Write FHTTPSEnabled; + end; + +//------------------------------------------------------------- +implementation +//------------------------------------------------------------- + +{ TSynTcpServer } + +constructor TSynTcpServer.Create(AOwner: TComponent); +begin + inherited; + // + FHost := '0.0.0.0'; +end; + +procedure TSynTcpServer.SetPort(const Value: string); +begin + SetActive(False); + FPort := Value; +end; + +procedure TSynTcpServer.SetLocalAddr(const Value: string); +begin + SetActive(False); + FHost := Value; +end; + +procedure TSynTcpServer.SetActive(Value: boolean); +begin + if (csDesigning in ComponentState) then + begin + // No real server at design-time... + FActive := Value; + Exit; + end; + if (csLoading in ComponentState) then + Exit; + // + if (FActive <> Value) then + begin + FActive := Value; + if FActive then + begin + if (FPort = '') then + raise ESynapseError.Create('Missing server Port'); + FSynapseServer := TListenerThread.Create(True, Self); + FSynapseServer.Port := FPort; + FSynapseServer.Host := FHost; + try + FSynapseServer.BindSocket + except + FreeAndNil(FSynapseServer); + FActive := False; + raise ESocketBindError.Create(Format('Couldnt bind socket on %s port', [FPort])); + end; + FSynapseServer.Start; + end + else + if Assigned(FSynapseServer) then + begin + FSynapseServer.Terminate; + FSynapseServer.WaitFor; + FreeAndNil(FSynapseServer); + //StopAllSessions; + end; + end; +end; + +{ TListenerThread } + +procedure TListenerThread.ClearFinishedThreads; +var + i: integer; +begin + for i := FThreadList.Count - 1 downto 0 do + if FThreadList[i].FFinished then + FThreadList.Remove(FThreadList[i]); +end; + +procedure TListenerThread.BindSocket; +var + e: ESynapseError; +begin + FSocket.CreateSocket; + FSocket.Bind(FHost, FPort); + if FSocket.LastError = 0 then + begin + FSocket.EnableReuse(True); + FSocket.Listen; + end + else + begin + e := ESynapseError.Create(Format('ListenThreadException %d: %s', [FSocket.LastError, FSocket.LastErrorDesc])); + e.ErrorCode := FSocket.LastError; + e.ErrorMessage := FSocket.LastErrorDesc; + raise e; + end; +end; + +constructor TListenerThread.Create(ASuspended: boolean; ATcpServer: TSynTcpServer); +begin + FSocket := TTCPBlockSocket.Create; + FThreadList := TObjectList.Create; + FTcpServer := ATcpServer; + inherited Create(ASuspended); +end; + +destructor TListenerThread.Destroy; +var + i: integer; +begin + FSocket.CloseSocket; + for i := 0 to FThreadList.Count - 1 do + begin + FThreadList[i].Terminate; + FThreadList[i].Socket.CloseSocket; + end; + ClearFinishedThreads; + FreeAndNil(FThreadList); + FreeAndNil(FSocket); + inherited; +end; + +procedure TListenerThread.Execute; +var + SynapseConnect: TSynTcpSrvConnection; +begin + inherited; + repeat + if FSocket.CanRead(100) then + begin + SynapseConnect := TSynTcpSrvConnection.Create(True, FSocket.Accept, FTcpServer); + FThreadList.Add(SynapseConnect); + SynapseConnect.Start; + end; + ClearFinishedThreads; + until Terminated; + try + FSocket.CloseSocket; + except + end; +end; + +{ TSynTcpSrvConnection } + +constructor TSynTcpSrvConnection.Create(ASuspended: boolean; ASocket: TSocket; ATcpServer: TSynTcpServer); +begin + inherited Create(ASuspended); + FSocket := TTCPBlockSocket.Create; + FSocket.Owner := Self; + FSocket.SSL.CertificateFile:= ATcpServer.FSynapseServer.FSocket.SSL.CertificateFile; + FSocket.SSL.PrivateKeyFile:= ATcpServer.FSynapseServer.FSocket.SSL.PrivateKeyFile; + FSocket.SSL.KeyPassword:= ATcpServer.FSynapseServer.FSocket.SSL.KeyPassword; + FSocket.SSL.VerifyCert:= ATcpServer.FSynapseServer.FSocket.SSL.VerifyCert; + FTcpServer := ATcpServer; + if ASocket <> INVALID_SOCKET then + begin + FSocket.Socket := ASocket; + FSocket.GetSins; + end; +end; + +destructor TSynTcpSrvConnection.Destroy; +begin + FSocket.CloseSocket; + inherited; + FreeAndNil(FSocket); +end; + +procedure TSynTcpSrvConnection.Execute; +var + Command: string; +begin + inherited; + if FSocket.SSL.VerifyCert then + try + if (not FSocket.SSLAcceptConnection) or (FSocket.SSL.LastError <> 0) then + begin + FFinished := True; + end; + except + FFinished := True; + end; + if not FFinished then + try + while not Terminated do + begin + Command := string(FSocket.RecvString({FSocket.GetRecvTimeout)}cDefLineTimeout)); + // Disconnect on timeout: + if (Command = '') and (FSocket.LastError <> 0) then + Break; + // + if Assigned(FTcpServer.FOnCommand) then // could be de-assigned? + FTcpServer.FOnCommand(Self, Command) + else + Break; + end; + finally + FFinished := True; + end; +end; + +function TSynTcpSrvConnection.GetClientAddress: string; +begin + Result := FSocket.GetRemoteSinIP; +end; + +function TSynTcpSrvConnection.GetClientPort: integer; +begin + Result := FSocket.GetRemoteSinPort; +end; + +end. diff --git a/Unit2.dfm b/Unit2.dfm new file mode 100644 index 0000000..3dfdbd6 --- /dev/null +++ b/Unit2.dfm @@ -0,0 +1,25 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 231 + ClientWidth = 505 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 208 + Top = 96 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Unit2.pas b/Unit2.pas new file mode 100644 index 0000000..fc83cf3 --- /dev/null +++ b/Unit2.pas @@ -0,0 +1,86 @@ +unit Unit2; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, SynHttpSrv, Vcl.StdCtrls, SynSrv; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + FSynHttpServer: TSynHttpServer; + { Private declarations } + procedure SynHttpServer1HttpGet(Sender: TObject; Connection: TSynTcpSrvConnection; + ARequestInfo, AResponseInfo: THttpRequest); + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); + + procedure TryToOpenWebPort; + var + s: string; + begin + try + if not FSynHttpServer.Active then + FSynHttpServer.Active := True; + except + on E: Exception do + begin + s := Format('Exception %s occurred while trying activate http or https connection. Message:"%s".', + [E.ClassName, E.Message]); + //Log(s); + end; + end; + end; + +begin + FSynHttpServer := TSynHttpServer.Create(Self); + FSynHttpServer.OnHttpGet := SynHttpServer1HttpGet; + FSynHttpServer.Port := '8080'; + TryToOpenWebPort; +end; + +procedure TForm2.SynHttpServer1HttpGet(Sender: TObject; Connection: TSynTcpSrvConnection; + ARequestInfo, AResponseInfo: THttpRequest); + + procedure WriteData; + begin + try + FSynHttpServer.SendReply(Connection, ARequestInfo, AResponseInfo); + except + On E: Exception do + if (Pos('10054', E.Message) = 0) and (Pos('10053', E.Message) = 0) then + {Log('Error; Exception occured. ' + E.Message)}; + end; + end; + + procedure RespString(const Str: string; const CharSet: string = ''); + begin + if Str.IsEmpty then + AResponseInfo.Content := ' ' + else + AResponseInfo.Content := Str; + AResponseInfo.ContentType := 'text/html'; + AResponseInfo.CharSet := CharSet; + AResponseInfo.StatusCode := 200; + WriteData; + end; + +begin + if ARequestInfo.Params.Values['Ping'] = 'Ping' then + RespString('Pong'); +end; + +end. diff --git a/asn1util.pas b/asn1util.pas new file mode 100644 index 0000000..6f29f05 --- /dev/null +++ b/asn1util.pas @@ -0,0 +1,521 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.001.000 | +|==============================================================================| +| Content: support for ASN.1 BER coding and decoding | +|==============================================================================| +| Copyright (c)1999-2014, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2014 | +| Portions created by Hernan Sanchez are Copyright (c) 2000. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Hernan Sanchez (hernan.sanchez@iname.com) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(Utilities for handling ASN.1 BER encoding) +By this unit you can parse ASN.1 BER encoded data to elements or build back any + elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to + human readable form for easy debugging, too. + +Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL, + ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER, + ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE + +For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class. +} + +{$Q-} +{$H+} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit asn1util; + +interface + +uses + SysUtils, Classes, synautil; + +const + ASN1_BOOL = $01; + ASN1_INT = $02; + ASN1_OCTSTR = $04; + ASN1_NULL = $05; + ASN1_OBJID = $06; + ASN1_ENUM = $0a; + ASN1_SEQ = $30; + ASN1_SETOF = $31; + ASN1_IPADDR = $40; + ASN1_COUNTER = $41; + ASN1_GAUGE = $42; + ASN1_TIMETICKS = $43; + ASN1_OPAQUE = $44; + ASN1_COUNTER64 = $46; + +{:Encodes OID item to binary form.} +function ASNEncOIDItem(Value: Int64): AnsiString; + +{:Decodes an OID item of the next element in the "Buffer" from the "Start" + position.} +function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64; + +{:Encodes the length of ASN.1 element to binary.} +function ASNEncLen(Len: Integer): AnsiString; + +{:Decodes length of next element in "Buffer" from the "Start" position.} +function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; + +{:Encodes a signed integer to ASN.1 binary} +function ASNEncInt(Value: Int64): AnsiString; + +{:Encodes unsigned integer into ASN.1 binary} +function ASNEncUInt(Value: Integer): AnsiString; + +{:Encodes ASN.1 object to binary form.} +function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; + +{:Beginning with the "Start" position, decode the ASN.1 item of the next element + in "Buffer". Type of item is stored in "ValueType."} +function ASNItem(var Start: Integer; const Buffer: AnsiString; + var ValueType: Integer): AnsiString; + +{:Encodes an MIB OID string to binary form.} +function MibToId(Mib: String): AnsiString; + +{:Decodes MIB OID from binary form to string form.} +function IdToMib(const Id: AnsiString): String; + +{:Encodes an one number from MIB OID to binary form. (used internally from +@link(MibToId))} +function IntMibToStr(const Value: AnsiString): AnsiString; + +{:Convert ASN.1 BER encoded buffer to human readable form for debugging.} +function ASNdump(const Value: AnsiString): AnsiString; + +implementation + +{==============================================================================} +function ASNEncOIDItem(Value: Int64): AnsiString; +var + x: Int64; + xm: Byte; + b: Boolean; +begin + x := Value; + b := False; + Result := ''; + repeat + xm := x mod 128; + x := x div 128; + if b then + xm := xm or $80; + if x > 0 then + b := True; + Result := AnsiChar(xm) + Result; + until x = 0; +end; + +{==============================================================================} +function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64; +var + x: Integer; + b: Boolean; +begin + Result := 0; + repeat + Result := Result * 128; + x := Ord(Buffer[Start]); + Inc(Start); + b := x > $7F; + x := x and $7F; + Result := Result + x; + until not b; +end; + +{==============================================================================} +function ASNEncLen(Len: Integer): AnsiString; +var + x, y: Integer; +begin + if Len < $80 then + Result := AnsiChar(Len) + else + begin + x := Len; + Result := ''; + repeat + y := x mod 256; + x := x div 256; + Result := AnsiChar(y) + Result; + until x = 0; + y := Length(Result); + y := y or $80; + Result := AnsiChar(y) + Result; + end; +end; + +{==============================================================================} +function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; +var + x, n: Integer; +begin + x := Ord(Buffer[Start]); + Inc(Start); + if x < $80 then + Result := x + else + begin + Result := 0; + x := x and $7F; + for n := 1 to x do + begin + Result := Result * 256; + x := Ord(Buffer[Start]); + Inc(Start); + Result := Result + x; + end; + end; +end; + +{==============================================================================} +function ASNEncInt(Value: Int64): AnsiString; +var + x: Int64; + y: byte; + neg: Boolean; +begin + neg := Value < 0; + x := Abs(Value); + if neg then + x := x - 1; + Result := ''; + repeat + y := x mod 256; + x := x div 256; + if neg then + y := not y; + Result := AnsiChar(y) + Result; + until x = 0; + if (not neg) and (Result[1] > #$7F) then + Result := #0 + Result; + if (neg) and (Result[1] < #$80) then + Result := #$FF + Result; +end; + +{==============================================================================} +function ASNEncUInt(Value: Integer): AnsiString; +var + x, y: Integer; + neg: Boolean; +begin + neg := Value < 0; + x := Value; + if neg then + x := x and $7FFFFFFF; + Result := ''; + repeat + y := x mod 256; + x := x div 256; + Result := AnsiChar(y) + Result; + until x = 0; + if neg then + Result[1] := AnsiChar(Ord(Result[1]) or $80); +end; + +{==============================================================================} +function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; +begin + Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; +end; + +{==============================================================================} +function ASNItem(var Start: Integer; const Buffer: AnsiString; + var ValueType: Integer): AnsiString; +var + ASNType: Integer; + ASNSize: Integer; + y: int64; + n: Integer; + x: byte; + s: AnsiString; + c: AnsiChar; + neg: Boolean; + l: Integer; +begin + Result := ''; + ValueType := ASN1_NULL; + l := Length(Buffer); + if l < (Start + 1) then + Exit; + s := ''; + ASNType := Ord(Buffer[Start]); + ValueType := ASNType; + Inc(Start); + ASNSize := ASNDecLen(Start, Buffer); + if (Start + ASNSize - 1) > l then + Exit; + if (ASNType and $20) > 0 then +// Result := '$' + IntToHex(ASNType, 2) + Result := Copy(Buffer, Start, ASNSize) + else + case ASNType of + ASN1_INT, ASN1_ENUM, ASN1_BOOL: + begin + y := 0; + neg := False; + for n := 1 to ASNSize do + begin + x := Ord(Buffer[Start]); + if (n = 1) and (x > $7F) then + neg := True; + if neg then + x := not x; + y := y * 256 + x; + Inc(Start); + end; + if neg then + y := -(y + 1); + Result := IntToStr(y); + end; + ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS, ASN1_COUNTER64: + begin + y := 0; + for n := 1 to ASNSize do + begin + y := y * 256 + Ord(Buffer[Start]); + Inc(Start); + end; + Result := IntToStr(y); + end; + ASN1_OCTSTR, ASN1_OPAQUE: + begin + for n := 1 to ASNSize do + begin + c := AnsiChar(Buffer[Start]); + Inc(Start); + s := s + c; + end; + Result := s; + end; + ASN1_OBJID: + begin + for n := 1 to ASNSize do + begin + c := AnsiChar(Buffer[Start]); + Inc(Start); + s := s + c; + end; + Result := IdToMib(s); + end; + ASN1_IPADDR: + begin + s := ''; + for n := 1 to ASNSize do + begin + if (n <> 1) then + s := s + '.'; + y := Ord(Buffer[Start]); + Inc(Start); + s := s + IntToStr(y); + end; + Result := s; + end; + ASN1_NULL: + begin + Result := ''; + Start := Start + ASNSize; + end; + else // unknown + begin + for n := 1 to ASNSize do + begin + c := AnsiChar(Buffer[Start]); + Inc(Start); + s := s + c; + end; + Result := s; + end; + end; +end; + +{==============================================================================} +function MibToId(Mib: String): AnsiString; +var + x: Integer; + + function WalkInt(var s: String): Integer; + var + x: Integer; + t: AnsiString; + begin + x := Pos('.', s); + if x < 1 then + begin + t := s; + s := ''; + end + else + begin + t := Copy(s, 1, x - 1); + s := Copy(s, x + 1, Length(s) - x); + end; + Result := StrToIntDef(t, 0); + end; + +begin + Result := ''; + x := WalkInt(Mib); + x := x * 40 + WalkInt(Mib); + Result := ASNEncOIDItem(x); + while Mib <> '' do + begin + x := WalkInt(Mib); + Result := Result + ASNEncOIDItem(x); + end; +end; + +{==============================================================================} +function IdToMib(const Id: AnsiString): String; +var + x, y, n: Integer; +begin + Result := ''; + n := 1; + while Length(Id) + 1 > n do + begin + x := ASNDecOIDItem(n, Id); + if (n - 1) = 1 then + begin + y := x div 40; + x := x mod 40; + Result := IntToStr(y); + end; + Result := Result + '.' + IntToStr(x); + end; +end; + +{==============================================================================} +function IntMibToStr(const Value: AnsiString): AnsiString; +var + n, y: Integer; +begin + y := 0; + for n := 1 to Length(Value) - 1 do + y := y * 256 + Ord(Value[n]); + Result := IntToStr(y); +end; + +{==============================================================================} +function ASNdump(const Value: AnsiString): AnsiString; +var + i, at, x, n: integer; + s, indent: AnsiString; + il: TStringList; +begin + il := TStringList.Create; + try + Result := ''; + i := 1; + indent := ''; + while i < Length(Value) do + begin + for n := il.Count - 1 downto 0 do + begin + x := StrToIntDef(il[n], 0); + if x <= i then + begin + il.Delete(n); + Delete(indent, 1, 2); + end; + end; + s := ASNItem(i, Value, at); + Result := Result + indent + '$' + IntToHex(at, 2); + if (at and $20) > 0 then + begin + x := Length(s); + Result := Result + ' constructed: length ' + IntToStr(x); + indent := indent + ' '; + il.Add(IntToStr(x + i - 1)); + end + else + begin + case at of + ASN1_BOOL: + Result := Result + ' BOOL: '; + ASN1_INT: + Result := Result + ' INT: '; + ASN1_ENUM: + Result := Result + ' ENUM: '; + ASN1_COUNTER: + Result := Result + ' COUNTER: '; + ASN1_GAUGE: + Result := Result + ' GAUGE: '; + ASN1_TIMETICKS: + Result := Result + ' TIMETICKS: '; + ASN1_OCTSTR: + Result := Result + ' OCTSTR: '; + ASN1_OPAQUE: + Result := Result + ' OPAQUE: '; + ASN1_OBJID: + Result := Result + ' OBJID: '; + ASN1_IPADDR: + Result := Result + ' IPADDR: '; + ASN1_NULL: + Result := Result + ' NULL: '; + ASN1_COUNTER64: + Result := Result + ' COUNTER64: '; + else // other + Result := Result + ' unknown: '; + end; + if IsBinaryString(s) then + s := DumpExStr(s); + Result := Result + s; + end; + Result := Result + #$0d + #$0a; + end; + finally + il.Free; + end; +end; + +{==============================================================================} + +end. diff --git a/blcksock.pas b/blcksock.pas new file mode 100644 index 0000000..75013d7 --- /dev/null +++ b/blcksock.pas @@ -0,0 +1,4603 @@ +{==============================================================================| +| Project : Ararat Synapse | 009.010.000 | +|==============================================================================| +| Content: Library base | +|==============================================================================| +| Copyright (c)1999-2017, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)1999-2017. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{ +Special thanks to Gregor Ibic + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about SSL programming. +} + +{$DEFINE ONCEWINSOCK} +{Note about define ONCEWINSOCK: +If you remove this compiler directive, then socket interface is loaded and +initialized on constructor of TBlockSocket class for each socket separately. +Socket interface is used only if your need it. + +If you leave this directive here, then socket interface is loaded and +initialized only once at start of your program! It boost performace on high +count of created and destroyed sockets. It eliminate possible small resource +leak on Windows systems too. +} + +{$DEFINE RAISEEXCEPT} +{When you enable this define, then is Raiseexcept property is on by default +} + +{:@abstract(Synapse's library core) + +Core with implementation basic socket classes. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} +{$ENDIF} +{$Q-} +{$H+} +{$M+} +{$TYPEDADDRESS OFF} + + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit blcksock; + +interface + +uses + SysUtils, Classes, + synafpc, synabyte, + synsock, synautil, synacode, synaip +{$IFDEF NEXTGEN} + , System.Generics.Collections, + System.Generics.Defaults +{$ENDIF} +{$IFDEF CIL} + ,System.Net + ,System.Net.Sockets + ,System.Text +{$ENDIF} + ; + +const + + SynapseRelease = '40'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + CR = #$0d; + LF = #$0a; + CRLF = CR + LF; + c64k = 65536; + +type + + {:@abstract(Exception clas used by Synapse) + When you enable generating of exceptions, this exception is raised by + Synapse's units.} + ESocketBindError = class(Exception); + + { ESynapseError } + + ESynapseError = class(Exception) + private + FErrorCode: Integer; + FErrorMessage: string; + public + constructor CreateErrorCode(AErrorCode:Integer; const AErrorDesc: string); + published + {:Code of error. Value depending on used operating system} + property ErrorCode: Integer read FErrorCode Write FErrorCode; + {:Human readable description of error.} + property ErrorMessage: string read FErrorMessage Write FErrorMessage; + end; + + ESynProtocolError = class(ESynapseError); + EResetByPeer = class (ESynapseError); + ECouldNotBindSocket = class (ESynapseError); + EConnectionResetByPeer = class (ESynapseError); + ESockectIsnotConnected = class (ESynapseError); + EConnectionTimedOut = class (ESynapseError); + EConnectionRefused = class (ESynapseError); + ECantAssignAddress = class (ESynapseError); + ESocketMinus2 = class (ESynapseError); + + {:Types of OnStatus events} + THookSocketReason = ( + {:Resolving is begin. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'.} + HR_ResolvingBegin, + {:Resolving is done. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!} + HR_ResolvingEnd, + {:Socket created by CreateSocket method. It reporting Family of created + socket too!} + HR_SocketCreate, + {:Socket closed by CloseSocket method.} + HR_SocketClose, + {:Socket binded to IP and Port. Binded IP and Port is in parameter in format + like: 'localhost.somewhere.com:25'.} + HR_Bind, + {:Socket connected to IP and Port. Connected IP and Port is in parameter in + format like: 'localhost.somewhere.com:25'.} + HR_Connect, + {:Called when CanRead method is used with @True result.} + HR_CanRead, + {:Called when CanWrite method is used with @True result.} + HR_CanWrite, + {:Socket is swithed to Listen mode. (TCP socket only)} + HR_Listen, + {:Socket Accepting client connection. (TCP socket only)} + HR_Accept, + {:report count of bytes readed from socket. Number is in parameter string. + If you need is in integer, you must use StrToInt function!} + HR_ReadCount, + {:report count of bytes writed to socket. Number is in parameter string. If + you need is in integer, you must use StrToInt function!} + HR_WriteCount, + {:If is limiting of bandwidth on, then this reason is called when sending or + receiving is stopped for satisfy bandwidth limit. Parameter is count of + waiting milliseconds.} + HR_Wait, + {:report situation where communication error occured. When raiseexcept is + @true, then exception is called after this Hook reason.} + HR_Error + ); + + {:Procedural type for OnStatus event. Sender is calling TBlockSocket object, + Reason is one of set Status events and value is optional data.} + THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; + const Value: string) of object; + + {:This procedural type is used for DataFilter hooks.} + THookDataFilter = procedure(Sender: TObject; var Value: string) of object; + + {:This procedural type is used for hook OnCreateSocket. By this hook you can + insert your code after initialisation of socket. (you can set special socket + options, etc.)} + THookCreateSocket = procedure(Sender: TObject) of object; + + {:This procedural type is used for monitoring of communication.} + THookMonitor = procedure(Sender: TObject; Writing: Boolean; + const Buffer: TMemory; Len: Integer) of object; + + {:This procedural type is used for hook OnAfterConnect. By this hook you can + insert your code after TCP socket has been sucessfully connected.} + THookAfterConnect = procedure(Sender: TObject) of object; + + {:This procedural type is used for hook OnVerifyCert. By this hook you can + insert your additional certificate verification code. Usefull to verify server + CN against URL. } + + THookVerifyCert = function(Sender: TObject):boolean of object; + + {:This procedural type is used for hook OnHeartbeat. By this hook you can + call your code repeately during long socket operations. + You must enable heartbeats by @Link(HeartbeatRate) property!} + THookHeartbeat = procedure(Sender: TObject) of object; + + {:Specify family of socket.} + TSocketFamily = ( + {:Default mode. Socket family is defined by target address for connection. + It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address + as destination, then is used IPv6 mode. othervise is used IPv4 mode. + However this mode not working properly with preliminary IPv6 supports!} + SF_Any, + {:Turn this class to pure IPv4 mode. This mode is totally compatible with + previous Synapse releases.} + SF_IP4, + {:Turn to only IPv6 mode.} + SF_IP6 + ); + + {:specify possible values of SOCKS modes.} + TSocksType = ( + ST_Socks5, + ST_Socks4 + ); + + {:Specify requested SSL/TLS version for secure connection.} + TSSLType = ( + LT_all, + LT_SSLv2, + LT_SSLv3, + LT_TLSv1, + LT_TLSv1_1, + LT_TLSv1_2, + LT_SSHv2 + ); + + {:Specify type of socket delayed option.} + TSynaOptionType = ( + SOT_Linger, + SOT_RecvBuff, + SOT_SendBuff, + SOT_NonBlock, + SOT_RecvTimeout, + SOT_SendTimeout, + SOT_Reuse, + SOT_TTL, + SOT_Broadcast, + SOT_MulticastTTL, + SOT_MulticastLoop, + SOT_NoDelay // TCP_NODELAY + ); + + {:@abstract(this object is used for remember delayed socket option set.)} + TSynaOption = class(TObject) + public + Option: TSynaOptionType; + Enabled: Boolean; + Value: Integer; + end; + + TCustomSSL = class; + TSSLClass = class of TCustomSSL; + + TBlockSocket = class; + +{$IFDEF NEXTGEN} + TOptionList = TList; + TSocketList = TList; +{$ELSE} + TOptionList = TList; + TSocketList = TList; +{$ENDIF} + {:@abstract(Basic IP object.) + This is parent class for other class with protocol implementations. Do not + use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket), + @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.} + TBlockSocket = class(TObject) + private + FOnStatus: THookSocketStatus; + FOnReadFilter: THookDataFilter; + FOnCreateSocket: THookCreateSocket; + FOnMonitor: THookMonitor; + FOnHeartbeat: THookHeartbeat; + FLocalSin: TVarSin; + FRemoteSin: TVarSin; + FTag: integer; + FBuffer: TSynaBytes; + FRaiseExcept: Boolean; + FNonBlockMode: Boolean; + FMaxLineLength: Integer; + FMaxSendBandwidth: Integer; + FNextSend: LongWord; + FMaxRecvBandwidth: Integer; + FNextRecv: LongWord; + FConvertLineEnd: Boolean; + FLastCR: Boolean; + FLastLF: Boolean; + FBinded: Boolean; + FFamily: TSocketFamily; + FFamilySave: TSocketFamily; + FIP6used: Boolean; + FPreferIP4: Boolean; + FDelayedOptions: TOptionList; + FInterPacketTimeout: Boolean; + {$IFNDEF CIL} + FFDSet: TFDSet; + {$ENDIF} + FRecvCounter: Integer; + FSendCounter: Integer; + FSendMaxChunk: Integer; + FStopFlag: Boolean; + FNonblockSendTimeout: Integer; + FHeartbeatRate: integer; + FConnectionTimeout: integer; + {$IFNDEF ONCEWINSOCK} + FWsaDataOnce: TWSADATA; + {$ENDIF} + FSocket: TSocket; + FLastError: Integer; + FLastErrorDesc: string; + FOwner: TObject; + function GetSizeRecvBuffer: Integer; + procedure SetSizeRecvBuffer(Size: Integer); + function GetSizeSendBuffer: Integer; + procedure SetSizeSendBuffer(Size: Integer); + procedure SetNonBlockMode(Value: Boolean); + procedure SetTTL(TTL: integer); + function GetTTL:integer; + procedure SetFamily(Value: TSocketFamily); virtual; + procedure SetSocket(Value: TSocket); virtual; + function GetWsaData: TWSAData; + function FamilyToAF(f: TSocketFamily): TAddrFamily; + procedure SetNagleMode(Value: Boolean); + procedure SetDelayedOption(const Value: TSynaOption); + procedure DelayedOption(const Value: TSynaOption); + procedure ProcessDelayedOptions; + procedure InternalCreateSocket(Sin: TVarSin); + procedure SetSin(var Sin: TVarSin; const IP, Port: string); + function GetSinIP(Sin: TVarSin): string; + function GetSinPort(Sin: TVarSin): Integer; + procedure DoStatus(Reason: THookSocketReason; const Value: string); + procedure DoReadFilter(Buffer: TMemory; var Len: Integer); + procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); + procedure DoCreateSocket; + procedure DoHeartbeat; + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); + procedure SetBandwidth(Value: Integer); + function TestStopFlag: Boolean; + procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; + function InternalCanRead(Timeout: Integer): Boolean; virtual; + function InternalCanWrite(Timeout: Integer): Boolean; virtual; + protected + FDisconnected: Boolean; + public + constructor Create; + + {:Create object and load all necessary socket library. What library is + loaded is described by STUB parameter. If STUB is empty string, then is + loaded default libraries.} + constructor CreateAlternate(Stub: string); + destructor Destroy; override; + + {:If @link(family) is not SF_Any, then create socket with type defined in + @link(Family) property. If family is SF_Any, then do nothing! (socket is + created automaticly when you know what type of socket you need to create. + (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created, + then is aplyed all stored delayed socket options.} + procedure CreateSocket; + + {:It create socket. Address resolving of Value tells what type of socket is + created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If + value is resolved as IPv6 address, then is created IPv6 socket.} + procedure CreateSocketByName(const Value: string); + + {:Destroy socket in use. This method is also automatically called from + object destructor.} + procedure CloseSocket; virtual; + + {:Abort any work on Socket and destroy them.} + procedure AbortSocket; virtual; + + {:Connects socket to local IP address and PORT. IP address may be numeric or + symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT + - it may be number or mnemonic port ('23', 'telnet'). + + If port value is '0', system chooses itself and conects unused port in the + range 1024 to 4096 (this depending by operating system!). Structure + LocalSin is filled after calling this method. + + Note: If you call this on non-created socket, then socket is created + automaticly. + + Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this + case is used implicit system bind instead.} + procedure Bind(const IP, Port: string); + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(BIND) method are valid. The only exception is that PORT with 0 value + will not be connected! + + Structures LocalSin and RemoteSin will be filled with valid values. + + When you call this on non-created socket, then socket is created + automaticly. Type of created socket is by @link(Family) property. If is + used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is + created socket for IPv6. When you have family on SF_Any (default!), then + type of created socket is determined by address resolving of destination + address. (Not work properly on prilimitary winsock IPv6 support!)} + procedure Connect(const IP, Port: string); virtual; + + {:Sets socket to receive mode for new incoming connections. It is necessary + to use @link(TBlockSocket.BIND) function call before this method to select + receiving port!} + procedure Listen; virtual; + + {:Waits until new incoming connection comes. After it comes a new socket is + automatically created (socket handler is returned by this function as + result).} + function Accept: TSocket; virtual; + + {:Sends data of LENGTH from BUFFER address via connected socket. System + automatically splits data to packets.} + function SendBuffer(const Buffer: Tmemory; Length: Integer): Integer; virtual; + + {:One data BYTE is sent via connected socket.} + procedure SendByte(Data: Byte); virtual; + + {:Send data string via connected socket. Any terminator is not added! If you + need send true string with CR-LF termination, you must add CR-LF characters + to sended string! Because any termination is not added automaticly, you can + use this function for sending any binary data in binary string.} + procedure SendString(Data: TSynaBytes); virtual; + + {:Send integer as four bytes to socket.} + procedure SendInteger(Data: integer); virtual; + + {:Send data as one block to socket. Each block begin with 4 bytes with + length of data in block. This 4 bytes is added automaticly by this + function.} + procedure SendBlock(const Data: string); virtual; + + {:Send data from stream to socket.} + procedure SendStreamRaw(const Stream: TStream); virtual; + + {:Send content of stream to socket. It using @link(SendBlock) method} + procedure SendStream(const Stream: TStream); virtual; + + {:Send content of stream to socket. It using @link(SendBlock) method and + this is compatible with streams in Indy library.} + procedure SendStreamIndy(const Stream: TStream); virtual; + + {:Note: This is low-level receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Waits until allocated buffer is filled by received data. Returns number of + data received, which equals to LENGTH value under normal operation. If it + is not equal the communication channel is possibly broken. + + On stream oriented sockets if is received 0 bytes, it mean 'socket is + closed!" + + On datagram socket is readed first waiting datagram.} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions! + + Method waits until data is received. If no data is received within TIMEOUT + (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods + serves for reading any size of data (i.e. one megabyte...). This method is + preffered for reading from stream sockets (like TCP).} + function RecvBufferEx(Buffer: Tmemory; Len: Integer; + Timeout: Integer): Integer; virtual; + + {:Similar to @link(RecvBufferEx), but readed data is stored in binary + string, not in memory buffer.} + function RecvBufferStr(Len: Integer; Timeout: Integer): TSynaBytes; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one data byte is received which is also returned as function + result. If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} + function RecvByte(Timeout: Integer): Byte; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one four bytes are received and return it as one Ineger Value. + If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} + function RecvInteger(Timeout: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + CR-LF characters. The resulting string is returned without this termination + (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be + exactly CR-LF. See @link(ConvertLineEnd) description. If no data is + received within TIMEOUT (in milliseconds) period, @link(LastError) is set + to WSAETIMEDOUT. You may also specify maximum length of reading data by + @link(MaxLineLength) property.} + function RecvString(Timeout: Integer): string; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + Terminator string. The resulting string is returned without this + termination. If no data is received within TIMEOUT (in milliseconds) + period, @link(LastError) is set to WSAETIMEDOUT. You may also specify + maximum length of reading data by @link(MaxLineLength) property.} + function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method reads all data waiting for read. If no data is received within + TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. + Methods serves for reading unknown size of data. Because before call this + function you don't know size of received data, returned data is stored in + dynamic size binary string. This method is preffered for reading from + stream sockets (like TCP). It is very goot for receiving datagrams too! + (UDP protocol)} + function RecvPacket(Timeout: Integer): TSynaBytes; virtual; + + {:Read one block of data from socket. Each block begin with 4 bytes with + length of data in block. This function read first 4 bytes for get lenght, + then it wait for reported count of bytes.} + function RecvBlock(Timeout: Integer): string; virtual; + + {:Read all data from socket to stream until socket is closed (or any error + occured.)} + procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; + {:Read requested count of bytes from socket to stream.} + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); + + {:Receive data to stream. It using @link(RecvBlock) method.} + procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; + + {:Receive data to stream. This function is compatible with similar function + in Indy library. It using @link(RecvBlock) method.} + procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; + + {:Same as @link(RecvBuffer), but readed data stays in system input buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} + function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Same as @link(RecvByte), but readed data stays in input system buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} + function PeekByte(Timeout: Integer): Byte; virtual; + + {:On stream sockets it returns number of received bytes waiting for picking. + 0 is returned when there is no such data. On datagram socket it returns + length of the first waiting datagram. Returns 0 if no datagram is waiting.} + function WaitingData: Integer; virtual; + + {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer), + return their length instead.} + function WaitingDataEx: Integer; + + {:Clear all waiting data for read from buffers.} + procedure Purge; + + {:Sets linger. Enabled linger means that the system waits another LINGER + (in milliseconds) time for delivery of sent data. This function is only for + stream type of socket! (TCP)} + procedure SetLinger(Enable: Boolean; Linger: Integer); + + {:Actualize values in @link(LocalSin).} + procedure GetSinLocal; + + {:Actualize values in @link(RemoteSin).} + procedure GetSinRemote; + + {:Actualize values in @link(LocalSin) and @link(RemoteSin).} + procedure GetSins; + + {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.} + procedure ResetLastError; + + {:If you "manually" call Socket API functions, forward their return code as + parameter to this function, which evaluates it, eventually calls + GetLastError and found error code returns and stores to @link(LastError).} + function SockCheck(SockResult: Integer): Integer; virtual; + + {:If @link(LastError) contains some error code and @link(RaiseExcept) + property is @true, raise adequate exception.} + procedure ExceptCheck; + + {:Returns local computer name as numerical or symbolic value. It try get + fully qualified domain name. Name is returned in the format acceptable by + functions demanding IP as input parameter.} + function LocalName: string; + + {:Try resolve name to all possible IP address. i.e. If you pass as name + result of @link(LocalName) method, you get all IP addresses used by local + system.} + procedure ResolveNameToIP(const Name: string; const IPList: TStrings); + + {:Try resolve name to primary IP address. i.e. If you pass as name result of + @link(LocalName) method, you get primary IP addresses used by local system.} + function ResolveName(const Name: string): string; + + {:Try resolve IP to their primary domain name. If IP not have domain name, + then is returned original IP.} + function ResolveIPToName(IP: string): string; + + {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)} + function ResolvePort(const Port: string): Word; + + {:Set information about remote side socket. It is good for seting remote + side for sending UDP packet, etc.} + procedure SetRemoteSin(const IP, Port: string); + + {:Picks IP socket address from @link(LocalSin).} + function GetLocalSinIP: string; virtual; + + {:Picks IP socket address from @link(RemoteSin).} + function GetRemoteSinIP: string; virtual; + + {:Picks socket PORT number from @link(LocalSin).} + function GetLocalSinPort: Integer; virtual; + + {:Picks socket PORT number from @link(RemoteSin).} + function GetRemoteSinPort: Integer; virtual; + + {:Return @TRUE, if you can read any data from socket or is incoming + connection on TCP based socket. Status is tested for time Timeout (in + milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. + + This function is need only on special cases, when you need use + @link(RecvBuffer) function directly! read functioms what have timeout as + calling parameter, calling this function internally.} + function CanRead(Timeout: Integer): Boolean; virtual; + + {:Same as @link(CanRead), but additionally return @TRUE if is some data in + @link(LineBuffer).} + function CanReadEx(Timeout: Integer): Boolean; virtual; + + {:Return @TRUE, if you can to socket write any data (not full sending + buffer). Status is tested for time Timeout (in milliseconds). If value in + Timeout is 0, status is only tested and continue. If value in Timeout is + -1, run is breaked and waiting for write data maybe forever. + + This function is need only on special cases!} + function CanWrite(Timeout: Integer): Boolean; virtual; + + {:Same as @link(SendBuffer), but send datagram to address from + @link(RemoteSin). Usefull for sending reply to datagram received by + function @link(RecvBufferFrom).} + function SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is low-lever receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Receives first waiting datagram to allocated buffer. If there is no waiting + one, then waits until one comes. Returns length of datagram stored in + BUFFER. If length exceeds buffer datagram is truncated. After this + @link(RemoteSin) structure contains information about sender of UDP packet.} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual; +{$IFNDEF CIL} + {:This function is for check for incoming data on set of sockets. Whitch + sockets is checked is decribed by SocketList Tlist with TBlockSocket + objects. TList may have maximal number of objects defined by FD_SETSIZE + constant. Return @TRUE, if you can from some socket read any data or is + incoming connection on TCP based socket. Status is tested for time Timeout + (in milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. If is returned @TRUE, CanReadList TList is filled by all + TBlockSocket objects what waiting for read.} + function GroupCanRead(const SocketList: TSocketList; Timeout: Integer; + const CanReadList: TSocketList): Boolean; +{$ENDIF} + {:By this method you may turn address reuse mode for local @link(bind). It + is good specially for UDP protocol. Using this with TCP protocol is + hazardous!} + procedure EnableReuse(Value: Boolean); + + {:Try set timeout for all sending and receiving operations, if socket + provider can do it. (It not supported by all socket providers!)} + procedure SetTimeout(Timeout: Integer); + + {:Try set timeout for all sending operations, if socket provider can do it. + (It not supported by all socket providers!)} + procedure SetSendTimeout(Timeout: Integer); + + {:Try set timeout for all receiving operations, if socket provider can do + it. (It not supported by all socket providers!)} + procedure SetRecvTimeout(Timeout: Integer); + + function GetSendTimeout: Integer; + + function GetRecvTimeout: integer; + + {:Return value of socket type.} + function GetSocketType: integer; Virtual; + + {:Return value of protocol type for socket creation.} + function GetSocketProtocol: integer; Virtual; + + {:WSA structure with information about socket provider. On non-windows + platforms this structure is simulated!} + property WSAData: TWSADATA read GetWsaData; + + {:FDset structure prepared for usage with this socket.} + property FDset: TFDSet read FFDset; + + {:Structure describing local socket side.} + property LocalSin: TVarSin read FLocalSin write FLocalSin; + + {:Structure describing remote socket side.} + property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; + + {:Socket handler. Suitable for "manual" calls to socket API or manual + connection of socket to a previously created socket (i.e by Accept method + on TCP socket)} + property Socket: TSocket read FSocket write SetSocket; + + {:Last socket operation error code. Error codes are described in socket + documentation. Human readable error description is stored in + @link(LastErrorDesc) property.} + property LastError: Integer read FLastError; + + {:Human readable error description of @link(LastError) code.} + property LastErrorDesc: string read FLastErrorDesc; + + {:Buffer used by all high-level receiving functions. This buffer is used for + optimized reading of data from socket. In normal cases you not need access + to this buffer directly!} + property LineBuffer: TSynaBytes read FBuffer write FBuffer; + + {:Size of Winsock receive buffer. If it is not supported by socket provider, + it return as size one kilobyte.} + property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; + + {:Size of Winsock send buffer. If it is not supported by socket provider, it + return as size one kilobyte.} + property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; + + {:If @True, turn class to non-blocking mode. Not all functions are working + properly in this mode, you must know exactly what you are doing! However + when you have big experience with non-blocking programming, then you can + optimise your program by non-block mode!} + property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; + + {:Set Time-to-live value. (if system supporting it!)} + property TTL: Integer read GetTTL Write SetTTL; + + {:If is @true, then class in in IPv6 mode.} + property IP6used: Boolean read FIP6used; + + {:Return count of received bytes on this socket from begin of current + connection.} + property RecvCounter: Integer read FRecvCounter; + + {:Return count of sended bytes on this socket from begin of current + connection.} + property SendCounter: Integer read FSendCounter; + published + {:Return descriptive string for given error code. This is class function. + You may call it without created object!} + class function GetErrorDesc(ErrorCode: Integer): string; + + {:Return descriptive string for @link(LastError).} + function GetErrorDescEx: string; virtual; + + {:this value is for free use.} + property Tag: Integer read FTag write FTag; + + {:If @true, winsock errors raises exception. Otherwise is setted + @link(LastError) value only and you must check it from your program! Default + value is @false.} + property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; + + {:Define maximum length in bytes of @link(LineBuffer) for high-level + receiving functions. If this functions try to read more data then this + limit, error is returned! If value is 0 (default), no limitation is used. + This is very good protection for stupid attacks to your server by sending + lot of data without proper terminator... until all your memory is allocated + by LineBuffer! + + Note: This maximum length is checked only in functions, what read unknown + number of bytes! (like @link(RecvString) or @link(RecvTerminated))} + property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; + + {:Define maximal bandwidth for all sending operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + + {:Define maximal bandwidth for all receiving operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + + {:Define maximal bandwidth for all sending and receiving operations in bytes + per second. If value is 0 (default), bandwidth limitation is not used.} + property MaxBandwidth: Integer Write SetBandwidth; + + {:Do a conversion of non-standard line terminators to CRLF. (Off by default) + If @True, then terminators like sigle CR, single LF or LFCR are converted + to CRLF internally. This have effect only in @link(RecvString) method!} + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Specified Family of this socket. When you are using Windows preliminary + support for IPv6, then I recommend to set this property!} + property Family: TSocketFamily read FFamily Write SetFamily; + + {:When resolving of domain name return both IPv4 and IPv6 addresses, then + specify if is used IPv4 (dafault - @true) or IPv6.} + property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; + + {:By default (@true) is all timeouts used as timeout between two packets in + reading operations. If you set this to @false, then Timeouts is for overall + reading operation!} + property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + + {:All sended datas was splitted by this value.} + property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk; + + {:By setting this property to @true you can stop any communication. You can + use this property for soft abort of communication.} + property StopFlag: Boolean read FStopFlag Write FStopFlag; + + {:Timeout for data sending by non-blocking socket mode.} + property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout; + + property NagleMode: Boolean write SetNagleMode; // True (Default) - TCP_NODELAY OFF + // False - TCP_NODELAY ON + + {:Timeout for @link(Connect) call. Default value 0 means default system timeout. + Non-zero value means timeout in millisecond.} + property ConnectionTimeout: Integer read FConnectionTimeout write FConnectionTimeout; + + {:This event is called by various reasons. It is good for monitoring socket, + create gauges for data transfers, etc.} + property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; + + {:this event is good for some internal thinks about filtering readed datas. + It is used by telnet client by example.} + property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; + + {:This event is called after real socket creation for setting special socket + options, because you not know when socket is created. (it is depended on + Ipv4, IPv6 or automatic mode)} + property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket; + + {:This event is good for monitoring content of readed or writed datas.} + property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; + + {:This event is good for calling your code during long socket operations. + (Example, for refresing UI if class in not called within the thread.) + Rate of heartbeats can be modified by @link(HeartbeatRate) property.} + property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat; + + {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing. + Default value 0 disabling heartbeats! Value is in milliseconds. + Real rate can be higher or smaller then this value, because it depending + on real socket operations too! + Note: Each heartbeat slowing socket processing.} + property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate; + {:What class own this socket? Used by protocol implementation classes.} + property Owner: TObject read FOwner Write FOwner; + end; + + {:@abstract(Support for SOCKS4 and SOCKS5 proxy) + Layer with definition all necessary properties and functions for + implementation SOCKS proxy client. Do not use this class directly.} + TSocksBlockSocket = class(TBlockSocket) + private + FSocksIP: string; + FSocksPort: string; + FSocksTimeout: integer; + FSocksUsername: string; + FSocksPassword: string; + FUsingSocks: Boolean; + FSocksResolver: Boolean; + FSocksLastError: integer; + FSocksResponseIP: string; + FSocksResponsePort: string; + FSocksLocalIP: string; + FSocksLocalPort: string; + FSocksRemoteIP: string; + FSocksRemotePort: string; + FBypassFlag: Boolean; + FSocksType: TSocksType; + function SocksCode(IP: string; const Port: string): string; + function SocksDecode(const Value: string): integer; + public + constructor Create; + + {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do + authorisation to proxy. This is needed only in special cases! (it is called + internally!)} + function SocksOpen: Boolean; + + {:Send specified request to SOCKS proxy. This is needed only in special + cases! (it is called internally!)} + function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean; + + {:Receive response to previosly sended request. This is needed only in + special cases! (it is called internally!)} + function SocksResponse: Boolean; + + {:Is @True when class is using SOCKS proxy.} + property UsingSocks: Boolean read FUsingSocks; + + {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.} + property SocksLastError: integer read FSocksLastError; + published + {:Address of SOCKS server. If value is empty string, SOCKS support is + disabled. Assingning any value to this property enable SOCKS mode. + Warning: You cannot combine this mode with HTTP-tunneling mode!} + property SocksIP: string read FSocksIP write FSocksIP; + + {:Port of SOCKS server. Default value is '1080'.} + property SocksPort: string read FSocksPort write FSocksPort; + + {:If you need authorisation on SOCKS server, set username here.} + property SocksUsername: string read FSocksUsername write FSocksUsername; + + {:If you need authorisation on SOCKS server, set password here.} + property SocksPassword: string read FSocksPassword write FSocksPassword; + + {:Specify timeout for communicatin with SOCKS server. Default is one minute.} + property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; + + {:If @True, all symbolic names of target hosts is not translated to IP's + locally, but resolving is by SOCKS proxy. Default is @True.} + property SocksResolver: Boolean read FSocksResolver write FSocksResolver; + + {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too. + When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is + used SOCKS4a. Othervise is used pure SOCKS4.} + property SocksType: TSocksType read FSocksType write FSocksType; + end; + + {:@abstract(Implementation of TCP socket.) + Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin), + SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy + (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} + TTCPBlockSocket = class(TSocksBlockSocket) + private + FOnAfterConnect: THookAfterConnect; + FSSL: TCustomSSL; + FHTTPTunnelIP: string; + FHTTPTunnelPort: string; + FHTTPTunnel: Boolean; + FHTTPTunnelRemoteIP: string; + FHTTPTunnelRemotePort: string; + FHTTPTunnelUser: string; + FHTTPTunnelPass: string; + FHTTPTunnelTimeout: integer; + procedure SocksDoConnect(const IP, Port: string); + procedure HTTPTunnelDoConnect(IP, Port: string); + procedure DoAfterConnect; + public + {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation + (see @link(SSLImplementation))} + constructor Create; + + {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation} + constructor CreateWithSSL(SSLPlugin: TSSLClass); + destructor Destroy; override; + + {:See @link(TBlockSocket.CloseSocket)} + procedure CloseSocket; override; + + {:See @link(TBlockSocket.WaitingData)} + function WaitingData: Integer; override; + + {:Sets socket to receive mode for new incoming connections. It is necessary + to use @link(TBlockSocket.BIND) function call before this method to select + receiving port! + + If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND + method of SOCKS.)} + procedure Listen; override; + + {:Waits until new incoming connection comes. After it comes a new socket is + automatically created (socket handler is returned by this function as + result). + + If you use SOCKS, new socket is not created! In this case is used same + socket as socket for listening! So, you can accept only one connection in + SOCKS mode.} + function Accept: TSocket; override; + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(TBlockSocket.BIND) method are valid. The only exception is that PORT + with 0 value will not be connected. After call to this method + a communication channel between local and remote socket is created. Local + socket is assigned automatically if not controlled by previous call to + @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin) + and @link(TBlockSocket.RemoteSin) will be filled with valid values. + + If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified + in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.) + + If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP + tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP + protocol.) + + Note: If you call this on non-created socket, then socket is created + automaticly.} + procedure Connect(const IP, Port: string); override; + + {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin + allows it) mode, then call this method. This method switch this class to + SSL mode and do SSL/TSL handshake.} + procedure SSLDoConnect; + + {:By this method you can downgrade existing SSL/TLS connection to normal TCP + connection.} + procedure SSLDoShutdown; + + {:If you need use this component as SSL/TLS TCP server, then after accepting + of inbound connection you need start SSL/TLS session by this method. Before + call this function, you must have assigned all neeeded certificates and + keys!} + function SSLAcceptConnection: Boolean; + + {:See @link(TBlockSocket.GetLocalSinIP)} + function GetLocalSinIP: string; override; + + {:See @link(TBlockSocket.GetRemoteSinIP)} + function GetRemoteSinIP: string; override; + + {:See @link(TBlockSocket.GetLocalSinPort)} + function GetLocalSinPort: Integer; override; + + {:See @link(TBlockSocket.GetRemoteSinPort)} + function GetRemoteSinPort: Integer; override; + + {:See @link(TBlockSocket.SendBuffer)} + function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBuffer)} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + + {:Return value of socket type. For TCP return SOCK_STREAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For TCP return + IPPROTO_TCP.} + function GetSocketProtocol: integer; override; + + function Connected: boolean; + + {:Class implementing SSL/TLS support. It is allways some descendant + of @link(TCustomSSL) class. When programmer not select some SSL plugin + class, then is used @link(TSSLNone)} + property SSL: TCustomSSL read FSSL; + + {:@True if is used HTTP tunnel mode.} + property HTTPTunnel: Boolean read FHTTPTunnel; + + property Disconnected: Boolean read FDisconnected write FDisconnected; + + published + {:Return descriptive string for @link(LastError). On case of error + in SSL/TLS subsystem, it returns right error description.} + function GetErrorDescEx: string; override; + + {:Specify IP address of HTTP proxy. Assingning non-empty value to this + property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing + TCP connection through HTTP proxy server. (If policy on HTTP proxy server + allow this!) Warning: You cannot combine this mode with SOCK5 mode!} + property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; + + {:Specify port of HTTP proxy for HTTP-tunneling.} + property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; + + {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel + mode. If you not need authorisation, then let this property empty.} + property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; + + {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel + mode.} + property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; + + {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} + property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; + + {:This event is called after sucessful TCP socket connection.} + property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect; + end; + + {:@abstract(Datagram based communication) + This class implementing datagram based communication instead default stream + based communication style.} + TDgramBlockSocket = class(TSocksBlockSocket) + protected + FUseConnect: Boolean; + public + {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for + sending data.} + procedure Connect(const IP, Port: string); override; + + {:Silently redirected to @link(TBlockSocket.SendBufferTo).} + function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override; + + {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override; + + {:Specify if connect should called on the underlying socket.} + property UseConnect: Boolean read FUseConnect Write FUseConnect; + end; + + {:@abstract(Implementation of UDP socket.) + NOTE: in this class is all receiving redirected to RecvBufferFrom. You can + use for reading any receive function. Preffered is RecvPacket! Similary all + sending is redirected to SendbufferTo. You can use for sending UDP packet any + sending function, like SendString. + + Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5 + proxy (only unicasts! Outgoing and incomming.)} + TUDPBlockSocket = class(TDgramBlockSocket) + protected + FSocksControlSock: TTCPBlockSocket; + function UdpAssociation: Boolean; + procedure SetMulticastTTL(TTL: integer); + function GetMulticastTTL:integer; + public + destructor Destroy; override; + + {:Enable or disable sending of broadcasts. If seting OK, result is @true. + This method is not supported in SOCKS5 mode! IPv6 does not support + broadcasts! In this case you must use Multicasts instead.} + procedure EnableBroadcast(Value: Boolean); + + {:See @link(TBlockSocket.SendBufferTo)} + function SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBufferFrom)} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override; +{$IFNDEF CIL} + {:Add this socket to given multicast group. You cannot use Multicasts in + SOCKS mode!} + procedure AddMulticast(const MCastIP:string); + + {:Remove this socket from given multicast group.} + procedure DropMulticast(const MCastIP:string); +{$ENDIF} + {:All sended multicast datagrams is loopbacked to your interface too. (you + can read your sended datas.) You can disable this feature by this function. + This function not working on some Windows systems!} + procedure EnableMulticastLoop(Value: Boolean); + + {:Return value of socket type. For UDP return SOCK_DGRAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For UDP return + IPPROTO_UDP.} + function GetSocketProtocol: integer; override; + + {:Set Time-to-live value for multicasts packets. It define number of routers + for transfer of datas. If you set this to 1 (dafault system value), then + multicasts packet goes only to you local network. If you need transport + multicast packet to worldwide, then increase this value, but be carefull, + lot of routers on internet does not transport multicasts packets!} + property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; + end; + + {:@abstract(Implementation of RAW ICMP socket.) + For this object you must have rights for creating RAW sockets!} + TICMPBlockSocket = class(TDgramBlockSocket) + public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For ICMP returns + IPPROTO_ICMP or IPPROTO_ICMPV6} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of RAW socket.) + For this object you must have rights for creating RAW sockets!} + TRAWBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For RAW returns + IPPROTO_RAW.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of PGM-message socket.) + Not all systems supports this protocol!} + TPGMMessageBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For PGM-message return SOCK_RDM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For PGM-message returns + IPPROTO_RM.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Implementation of PGM-stream socket.) + Not all systems supports this protocol!} + TPGMStreamBlockSocket = class(TBlockSocket) + public + {:Return value of socket type. For PGM-stream return SOCK_STREAM.} + function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For PGM-stream returns + IPPROTO_RM.} + function GetSocketProtocol: integer; override; + end; + + {:@abstract(Parent class for all SSL plugins.) + This is abstract class defining interface for other SSL plugins. + + Instance of this class will be created for each @link(TTCPBlockSocket). + + Warning: not all methods and propertis can work in all existing SSL plugins! + Please, read documentation of used SSL plugin.} + TCustomSSL = class(TObject) + private + FOnVerifyCert: THookVerifyCert; + FCertCA: string; + FTrustCertificate: string; + FTrustCertificateFile: string; + FUsername: string; + FPassword: string; + FSSHChannelType: string; + FSSHChannelArg1: string; + FSSHChannelArg2: string; + FCertComplianceLevel: integer; + FSNIHost: string; + procedure ReturnError; + procedure SetCertCAFile(const Value: string); virtual; + protected + FCiphers: string; + FPrivateKey: string; + FSSLEnabled: Boolean; + FSocket: TTCPBlockSocket; + FKeyPassword: string; + FSSLType: TSSLType; + FVerifyCert: Boolean; + FCertificateFile: string; + FCertCAFile: string; + FPFXfile: string; + FPFX: string; + FPrivateKeyFile: string; + FLastErrorDesc: string; + FLastError: integer; + FCertificate: string; + function DoVerifyCert:boolean; + function CreateSelfSignedCert(Host: string): Boolean; virtual; + public + {: Create plugin class. it is called internally from @link(TTCPBlockSocket)} + constructor Create(const Value: TTCPBlockSocket); virtual; + + {: Assign settings (certificates and configuration) from another SSL plugin + class.} + procedure Assign(const Value: TCustomSSL); virtual; + + {: return description of used plugin. It usually return name and version + of used SSL library.} + function LibVersion: string; virtual; + + {: return name of used plugin.} + function LibName: string; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for start SSL connection.} + function Connect: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for acept new SSL connection.} + function Accept: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for hard shutdown of SSL connection. (for example, + before socket is closed)} + function Shutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for soft shutdown of SSL connection. (for example, + when you need to continue with unprotected connection.)} + function BiShutdown: boolean; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for sending some datas by SSL connection.} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for receiving some datas by SSL connection.} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; + + {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! + + Here is needed code for getting count of datas what waiting for read. + If SSL plugin not allows this, then it should return 0.} + function WaitingData: Integer; virtual; + + {:Return string with identificator of SSL/TLS version of existing + connection.} + function GetSSLVersion: string; virtual; + + {:Return subject of remote SSL peer.} + function GetPeerSubject: string; virtual; + + {:Return Serial number if remote X509 certificate.} + function GetPeerSerialNo: integer; virtual; + + {:Return issuer certificate of remote SSL peer.} + function GetPeerIssuer: string; virtual; + + {:Return peer name from remote side certificate. This is good for verify, + if certificate is generated for remote side IP name.} + function GetPeerName: string; virtual; + + {:Returns has of peer name from remote side certificate. This is good + for fast remote side authentication.} + function GetPeerNameHash: cardinal; virtual; + + {:Return fingerprint of remote SSL peer.} + function GetPeerFingerprint: string; virtual; + + function GetPeerFingerprintDigest(const ADigest: string): string; virtual; abstract; + + {:Return all detailed information about certificate from remote side of + SSL/TLS connection. Result string can be multilined! Each plugin can return + this informations in different format!} + function GetCertInfo: string; virtual; + + {:Return currently used Cipher.} + function GetCipherName: string; virtual; + + {:Return currently used number of bits in current Cipher algorythm.} + function GetCipherBits: integer; virtual; + + {:Return number of bits in current Cipher algorythm.} + function GetCipherAlgBits: integer; virtual; + + {:Return result value of verify remote side certificate. Look to OpenSSL + documentation for possible values. For example 0 is successfuly verified + certificate, or 18 is self-signed certificate.} + function GetVerifyCert: integer; virtual; + + {: Resurn @true if SSL mode is enabled on existing cvonnection.} + property SSLEnabled: Boolean read FSSLEnabled; + + {:Return error code of last SSL operation. 0 is OK.} + property LastError: integer read FLastError; + + {:Return error description of last SSL operation.} + property LastErrorDesc: string read FLastErrorDesc; + published + {:Here you can specify requested SSL/TLS mode. Default is autodetection, but + on some servers autodetection not working properly. In this case you must + specify requested SSL/TLS mode by your hand!} + property SSLType: TSSLType read FSSLType write FSSLType; + + {:Password for decrypting of encoded certificate or key.} + property KeyPassword: string read FKeyPassword write FKeyPassword; + + {:Username for possible credentials.} + property Username: string read FUsername write FUsername; + + {:password for possible credentials.} + property Password: string read FPassword write FPassword; + + {:By this property you can modify default set of SSL/TLS ciphers.} + property Ciphers: string read FCiphers write FCiphers; + + {:Used for loading certificate from disk file. See to plugin documentation + if this method is supported and how!} + property CertificateFile: string read FCertificateFile write FCertificateFile; + + {:Used for loading private key from disk file. See to plugin documentation + if this method is supported and how!} + property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile; + + {:Used for loading certificate from binary string. See to plugin documentation + if this method is supported and how!} + property Certificate: string read FCertificate write FCertificate; + + {:Used for loading private key from binary string. See to plugin documentation + if this method is supported and how!} + property PrivateKey: string read FPrivateKey write FPrivateKey; + + {:Used for loading PFX from binary string. See to plugin documentation + if this method is supported and how!} + property PFX: string read FPFX write FPFX; + + {:Used for loading PFX from disk file. See to plugin documentation + if this method is supported and how!} + property PFXfile: string read FPFXfile write FPFXfile; + + {:Used for loading trusted certificates from disk file. See to plugin documentation + if this method is supported and how!} + property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile; + + {:Used for loading trusted certificates from binary string. See to plugin documentation + if this method is supported and how!} + property TrustCertificate: string read FTrustCertificate write FTrustCertificate; + + {:Used for loading CA certificates from binary string. See to plugin documentation + if this method is supported and how!} + property CertCA: string read FCertCA write FCertCA; + + {:Used for loading CA certificates from disk file. See to plugin documentation + if this method is supported and how!} + property CertCAFile: string read FCertCAFile write SetCertCAFile; + + {:If @true, then is verified client certificate. (it is good for writing + SSL/TLS servers.) When you are not server, but you are client, then if this + property is @true, verify servers certificate.} + property VerifyCert: Boolean read FVerifyCert write FVerifyCert; + + {:channel type for possible SSH connections} + property SSHChannelType: string read FSSHChannelType write FSSHChannelType; + + {:First argument of channel type for possible SSH connections} + property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1; + + {:Second argument of channel type for possible SSH connections} + property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2; + + {: Level of standards compliance level + (CryptLib: values in cryptlib.pas, -1: use default value ) } + property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel; + + {:This event is called when verifying the server certificate immediatally after + a successfull verification in the ssl library.} + property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert; + + {: Server Name Identification. Host name to send to server. If empty the host name + found in URL will be used, which should be the normal use (http Header Host = SNI Host). + The value is cleared after the connection is established. + (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet ) } + property SNIHost:string read FSNIHost write FSNIHost; + end; + + {:@abstract(Default SSL plugin with no SSL support.) + Dummy SSL plugin implementation for applications without SSL/TLS support.} + TSSLNone = class (TCustomSSL) + public + {:See @inherited} + function LibVersion: string; override; + {:See @inherited} + function LibName: string; override; + end; + + {:@abstract(Record with definition of IP packet header.) + For reading data from ICMP or RAW sockets.} + TIPHeader = record + VerLen: Byte; + TOS: Byte; + TotalLen: Word; + Identifer: Word; + FragOffsets: Word; + TTL: Byte; + Protocol: Byte; + CheckSum: Word; + SourceIp: LongWord; + DestIp: LongWord; + Options: LongWord; + end; + + {:@abstract(Parent class of application protocol implementations.) + By this class is defined common properties.} + TSynaClient = Class(TObject) + protected + FTargetHost: string; + FTargetPort: string; + FIPInterface: string; + FTimeout: integer; + FUserName: string; + FPassword: string; + public + constructor Create; + published + {:Specify terget server IP (or symbolic name). Default is 'localhost'.} + property TargetHost: string read FTargetHost Write FTargetHost; + + {:Specify terget server port (or symbolic name).} + property TargetPort: string read FTargetPort Write FTargetPort; + + {:Defined local socket address. (outgoing IP address). By default is used + '0.0.0.0' as wildcard for default IP.} + property IPInterface: string read FIPInterface Write FIPInterface; + + {:Specify default timeout for socket operations.} + property Timeout: integer read FTimeout Write FTimeout; + + {:If protocol need user authorization, then fill here username.} + property UserName: string read FUserName Write FUserName; + + {:If protocol need user authorization, then fill here password.} + property Password: string read FPassword Write FPassword; + end; + +var + {:Selected SSL plugin. Default is @link(TSSLNone). + + Do not change this value directly!!! + + Just add your plugin unit to your project uses instead. Each plugin unit have + initialization code what modify this variable.} + SSLImplementation: TSSLClass = TSSLNone; + +implementation + +{$IFDEF ONCEWINSOCK} +var + WsaDataOnce: TWSADATA; + e: ESynapseError; + +{ ESynapseError } + +constructor ESynapseError.CreateErrorCode(AErrorCode: Integer; + const AErrorDesc: string); +var + Z: string; +begin + Z := SysUtils.Trim(AErrorDesc); + inherited Create(Z); + FErrorCode := AErrorCode; + FErrorMessage := Z; +end; + +{$ENDIF} + + +constructor TBlockSocket.Create; +begin + CreateAlternate(''); +end; + +constructor TBlockSocket.CreateAlternate(Stub: string); +{$IFNDEF ONCEWINSOCK} +var + e: ESynapseError; +{$ENDIF} +begin + inherited Create; + FDelayedOptions := TOptionList.Create; + FRaiseExcept := False; +{$IFDEF RAISEEXCEPT} + FRaiseExcept := True; +{$ENDIF} + FSocket := INVALID_SOCKET; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + FBinded := False; + FNonBlockMode := False; + FMaxLineLength := 0; + FMaxSendBandwidth := 0; + FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; + FFamily := SF_Any; + FFamilySave := SF_Any; + FIP6used := False; + FPreferIP4 := True; + FInterPacketTimeout := True; + FRecvCounter := 0; + FSendCounter := 0; + FSendMaxChunk := c64k; + FStopFlag := False; + FNonblockSendTimeout := 15000; + FHeartbeatRate := 0; + FConnectionTimeout := 0; + FOwner := nil; +{$IFNDEF ONCEWINSOCK} + if Stub = '' then + Stub := DLLStackName; + if not InitSocketInterface(Stub) then + begin + e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!'; + raise e; + end; + SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce)); + ExceptCheck; +{$ENDIF} +end; + +destructor TBlockSocket.Destroy; +var + n: integer; + p: TSynaOption; +begin + CloseSocket; +{$IFNDEF ONCEWINSOCK} + synsock.WSACleanup; + DestroySocketInterface; +{$ENDIF} + for n := FDelayedOptions.Count - 1 downto 0 do + begin + p := TSynaOption(FDelayedOptions[n]); + p.Free; + end; + FDelayedOptions.Free; + inherited Destroy; +end; + +function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily; +begin + case f of + SF_ip4: + Result := AF_INET; + SF_ip6: + Result := AF_INET6; + else + Result := AF_UNSPEC; + end; +end; + +procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); +var + li: TLinger; + x: integer; + buf: TMemory; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + timeval: TTimeval; +{$ENDIF} +{$ENDIF} +begin + case value.Option of + SOT_Linger: + begin + {$IFDEF CIL} + li := TLinger.Create(Value.Enabled, Value.Value div 1000); + synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li); + {$ELSE} + li.l_onoff := Ord(Value.Enabled); + li.l_linger := Value.Value div 1000; + buf := @li; + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li))); + ExceptCheck; + {$ENDIF} + end; + SOT_RecvBuff: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), + buf, SizeOf(Value.Value))); + ExceptCheck; + end; + SOT_SendBuff: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), + buf, SizeOf(Value.Value))); + ExceptCheck; + end; + SOT_NonBlock: + begin + FNonBlockMode := Value.Enabled; + x := Ord(FNonBlockMode); + SockCheck(synsock.IoctlSocket(FSocket, FIONBIO, x)); + ExceptCheck; + end; + SOT_RecvTimeout: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + {$IFDEF MSWINDOWS} + buf := @Value.Value; + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value))); + ExceptCheck; + {$ELSE} + {$IFDEF ULTIBO} + buf := @Value.Value; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + timeval.tv_sec:=Value.Value div 1000; + timeval.tv_usec:=(Value.Value mod 1000) * 1000; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + @timeval, SizeOf(timeval)); + {$ENDIF} + {$ENDIF} + {$ENDIF} + end; + SOT_SendTimeout: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + {$IFDEF MSWINDOWS} + buf := @Value.Value; + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + buf, SizeOf(Value.Value))); + ExceptCheck; + {$ELSE} + {$IFDEF ULTIBO} + buf := @Value.Value; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + buf, SizeOf(Value.Value)); + {$ELSE} + timeval.tv_sec:=Value.Value div 1000; + timeval.tv_usec:=(Value.Value mod 1000) * 1000; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + @timeval, SizeOf(timeval)); + {$ENDIF} + {$ENDIF} + {$ENDIF} + end; + SOT_Reuse: + begin + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x))); + ExceptCheck; + end; + SOT_TTL: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + if FIP6Used then + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS), + buf, SizeOf(Value.Value))) + else + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL), + buf, SizeOf(Value.Value))); + ExceptCheck; + end; + SOT_Broadcast: + begin +//#todo1 broadcasty na IP6 + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x))); + ExceptCheck; + end; + SOT_MulticastTTL: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + if FIP6Used then + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS), + buf, SizeOf(Value.Value))) + else + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL), + buf, SizeOf(Value.Value))); + ExceptCheck; + end; + SOT_MulticastLoop: + begin + x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + if FIP6Used then + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x))) + else + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x))); + ExceptCheck; + end; + SOT_NoDelay: + begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + x := Ord(Value.Enabled); + SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(TCP_NODELAY), buf, SizeOf(x))); + ExceptCheck; + end; + end; + Value.free; +end; + +procedure TBlockSocket.DelayedOption(const Value: TSynaOption); +begin + if FSocket = INVALID_SOCKET then + begin + FDelayedOptions.Insert(0, Value); + end + else + SetDelayedOption(Value); +end; + +procedure TBlockSocket.ProcessDelayedOptions; +var + n: integer; + d: TSynaOption; +begin + for n := FDelayedOptions.Count - 1 downto 0 do + begin + d := TSynaOption(FDelayedOptions[n]); + SetDelayedOption(d); + end; + FDelayedOptions.Clear; +end; + +procedure TBlockSocket.SetSin(var Sin: TVarSin; const IP, Port: string); +var + f: TSocketFamily; +begin + DoStatus(HR_ResolvingBegin, IP + ':' + Port); + ResetLastError; + //if socket exists, then use their type, else use users selection + f := SF_Any; + if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then + begin + if IsIP(IP) then + f := SF_IP4 + else + if IsIP6(IP) then + f := SF_IP6; + end + else + f := FFamily; + FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f), + GetSocketprotocol, GetSocketType, FPreferIP4); + DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin))); +end; + +function TBlockSocket.GetSendTimeout: Integer; +var + l: integer; +begin + l:=SizeOf(Integer); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @Result, l)); + ExceptCheck; +end; + +function TBlockSocket.GetSinIP(Sin: TVarSin): string; +begin + Result := synsock.GetSinIP(sin); +end; + +function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; +begin + Result := synsock.GetSinPort(sin); +end; + +procedure TBlockSocket.CreateSocket; +var + sin: TVarSin; +begin + //dummy for SF_Any Family mode + ResetLastError; + if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then + begin + {$IFDEF CIL} + if FFamily = SF_IP6 then + sin := TVarSin.Create(IPAddress.Parse('::0'), 0) + else + sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0); + {$ELSE} + FillChar(Sin, Sizeof(Sin), 0); + if FFamily = SF_IP6 then + sin.sin_family := AF_INET6 + else + sin.sin_family := AF_INET; + {$ENDIF} + InternalCreateSocket(Sin); + end; +end; + +procedure TBlockSocket.CreateSocketByName(const Value: string); +var + sin: TVarSin; +begin + ResetLastError; + if FSocket = INVALID_SOCKET then + begin + SetSin(sin, value, '0'); + if FLastError = 0 then + InternalCreateSocket(Sin); + end; +end; + +procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); +begin + FStopFlag := False; + FRecvCounter := 0; + FSendCounter := 0; + ResetLastError; + if FSocket = INVALID_SOCKET then + begin + FBuffer := ''; + FBinded := False; + FIP6Used := Sin.AddressFamily = AF_INET6; + FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol); + if FSocket = INVALID_SOCKET then + FLastError := synsock.WSAGetLastError; + {$IFNDEF CIL} + FD_ZERO(FFDSet); + FD_SET(FSocket, FFDSet); + {$ENDIF} + ExceptCheck; + if FIP6used then + DoStatus(HR_SocketCreate, 'IPv6') + else + DoStatus(HR_SocketCreate, 'IPv4'); + ProcessDelayedOptions; + DoCreateSocket; + end; +end; + +procedure TBlockSocket.CloseSocket; +begin + AbortSocket; +end; + +procedure TBlockSocket.AbortSocket; +var + n: integer; + p: TSynaOption; +begin + if FSocket <> INVALID_SOCKET then + synsock.CloseSocket(FSocket); + FSocket := INVALID_SOCKET; + for n := FDelayedOptions.Count - 1 downto 0 do + begin + p := TSynaOption(FDelayedOptions[n]); + p.Free; + end; + FDelayedOptions.Clear; + FFamily := FFamilySave; + DoStatus(HR_SocketClose, ''); + FDisconnected := False; +end; + +procedure TBlockSocket.Bind(const IP, Port: string); +var + Sin: TVarSin; +begin + ResetLastError; + if (FSocket <> INVALID_SOCKET) + or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then + begin + SetSin(Sin, IP, Port); + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + SockCheck(synsock.Bind(FSocket, Sin)); + GetSinLocal; + FBuffer := ''; + FBinded := True; + end; + ExceptCheck; + DoStatus(HR_Bind, IP + ':' + Port); + end; +end; + +procedure TBlockSocket.Connect(const IP, Port: string); +var + Sin: TVarSin; + b: boolean; + lError: Integer; +begin + SetSin(Sin, IP, Port); + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + if FConnectionTimeout > 0 then + begin + // connect in non-blocking mode + b := NonBlockMode; + NonBlockMode := true; + SockCheck(synsock.Connect(FSocket, Sin)); + if (FLastError = WSAEINPROGRESS) OR (FLastError = WSAEWOULDBLOCK) then + if not CanWrite(FConnectionTimeout) then + FLastError := WSAETIMEDOUT; + lError := FLastError; + NonBlockMode := b; + FLastError := lError; + end + else + SockCheck(synsock.Connect(FSocket, Sin)); + if FLastError = 0 then + GetSins; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + end; + ExceptCheck; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +procedure TBlockSocket.Listen; +begin + SockCheck(synsock.Listen(FSocket, SOMAXCONN)); + GetSins; + ExceptCheck; + DoStatus(HR_Listen, ''); +end; + +function TBlockSocket.Accept: TSocket; +begin + Result := synsock.Accept(FSocket, FRemoteSin); +/// SockCheck(Result); + ExceptCheck; + DoStatus(HR_Accept, ''); +end; + +procedure TBlockSocket.GetSinLocal; +begin + synsock.GetSockName(FSocket, FLocalSin); +end; + +procedure TBlockSocket.GetSinRemote; +begin + synsock.GetPeerName(FSocket, FRemoteSin); +end; + +procedure TBlockSocket.GetSins; +begin + GetSinLocal; + GetSinRemote; +end; + +procedure TBlockSocket.SetBandwidth(Value: Integer); +begin + MaxSendBandwidth := Value; + MaxRecvBandwidth := Value; +end; + +procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); +var + x: LongWord; + y: LongWord; + n: integer; +begin + if FStopFlag then + exit; + if MaxB > 0 then + begin + y := GetTick; + if Next > y then + begin + x := Next - y; + if x > 0 then + begin + DoStatus(HR_Wait, IntToStr(x)); + sleep(x mod 250); + for n := 1 to x div 250 do + if FStopFlag then + Break + else + sleep(250); + end; + end; + Next := GetTick + Trunc((Length / MaxB) * 1000); + end; +end; + +function TBlockSocket.TestStopFlag: Boolean; +begin + DoHeartbeat; + Result := FStopFlag; + if Result then + begin + FStopFlag := False; + FLastError := WSAECONNABORTED; + ExceptCheck; + end; +end; + + +function TBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; +{$IFNDEF CIL} +var + x, y: integer; + l, r: integer; + p: Pointer; +{$ENDIF} +begin + Result := 0; + if TestStopFlag then + Exit; + DoMonitor(True, Buffer, Length); +{$IFDEF CIL} + Result := synsock.Send(FSocket, Buffer, Length, 0); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + if FLastError = WSAEWOULDBLOCK then + begin + if CanWrite(FNonblockSendTimeout) then + begin + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + end + else + FLastError := WSAETIMEDOUT; + end; + if FLastError <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} + ExceptCheck; +end; + +procedure TBlockSocket.SendByte(Data: Byte); +{$IFDEF CIL} +var + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 1); + buf[0] := Data; + SendBuffer(buf, 1); +{$ELSE} + SendBuffer(@Data, 1); +{$ENDIF} +end; + +procedure TBlockSocket.SendString(Data: TSynaBytes); +var + buf: TMemory; + count: Integer; +begin + {$IFDEF CIL} + buf := BytesOf(Data); + count := Length(Data); + {$ELSE} + {$IFDEF UNICODE} + buf := TSynaBytes(Data).Data; //TSynaByte(Data) + count := Data.Length; // avoid conversion + {$ELSE} + buf := Pointer(data); + count := Length(Data); + {$ENDIF} + {$ENDIF} + SendBuffer(buf, count); +end; + +procedure TBlockSocket.SendInteger(Data: integer); +var + buf: TMemory; +begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(Data); + {$ELSE} + buf := @Data; + {$ENDIF} + SendBuffer(buf, SizeOf(Data)); +end; + +procedure TBlockSocket.SendBlock(const Data: string); +var + i: integer; +begin + i := SwapBytes(Length(data)); + SendString(Codelongint(i) + Data); +end; + +procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); +var + l: integer; + yr: integer; + s: string; + b: boolean; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + b := true; + l := 0; + if WithSize then + begin + l := Stream.Size - Stream.Position;; + if not Indy then + l := synsock.HToNL(l); + end; + repeat + {$IFDEF CIL} + Setlength(buf, FSendMaxChunk); + yr := Stream.read(buf, FSendMaxChunk); + if yr > 0 then + begin + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l)); + end; + SendBuffer(buf, yr); + if FLastError <> 0 then + break; + end + {$ELSE} + Setlength(s, FSendMaxChunk); + yr := Stream.read(Pointer(s)^, FSendMaxChunk); + if yr > 0 then + begin + SetLength(s, yr); + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l) + s); + end + else + SendString(s); + if FLastError <> 0 then + break; + end + {$ENDIF} + until yr <= 0; +end; + +procedure TBlockSocket.SendStreamRaw(const Stream: TStream); +begin + InternalSendStream(Stream, false, false); +end; + +procedure TBlockSocket.SendStreamIndy(const Stream: TStream); +begin + InternalSendStream(Stream, true, true); +end; + +procedure TBlockSocket.SendStream(const Stream: TStream); +begin + InternalSendStream(Stream, true, false); +end; + +function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL); + if Result = 0 then + FLastError := WSAECONNRESET + else + SockCheck(Result); + ExceptCheck; + if Result > 0 then + begin + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); + DoReadFilter(Buffer, Result); + end; +end; + +function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; + Timeout: Integer): Integer; +var + s: TSynaBytes; + rl, l: integer; + ti: LongWord; +{$IFDEF CIL} + n: integer; + b: TMemory; +{$ENDIF} +begin + ResetLastError; + Result := 0; + if Len > 0 then + begin + rl := 0; + repeat + ti := GetTick; + s := RecvPacket(Timeout); + l := s.length; + if (rl + l) > Len then + l := Len - rl; + {$IFDEF CIL} + b := BytesOf(s); + for n := 0 to l do + Buffer[rl + n] := b[n]; + {$ELSE} + Move({$IFNDEF UNICODE}Pointer(s)^{$ELSE}s.Bytes[0]{$ENDIF}, + IncPoint(Buffer, rl)^, l); + {$ENDIF} + rl := rl + l; + if FLastError <> 0 then + Break; + if rl >= Len then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + FLastError := WSAETIMEDOUT; + Break; + end; + end; + until False; + DeleteInternal(s, 1, l); + FBuffer := s; + Result := rl; + end; +end; + +function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): TSynaBytes; +var + x: integer; + buf: TBytes; +begin + Result := ''; + if Len > 0 then + begin + Setlength(Buf, Len); + x := RecvBufferEx(@buf[0], Len, Timeout); + if FLastError = 0 then + begin + SetLength(Buf, x); + {$IFDEF UNICODE} + Result.Length := x; + Move(Buf[0], Result.Bytes[0], x); + {$ELSE} + Result := StringOf(Buf); + {$ENDIF} + end + else + Result := ''; + Setlength(Buf, 0); + end; +end; + +function TBlockSocket.RecvPacket(Timeout: Integer): TSynaBytes; +var + x: Integer; + buf: TBytes; +begin + Result := ''; + ResetLastError; + if FBuffer <> '' then + begin + Result := FBuffer; + FBuffer := ''; + end + else + begin + {$IFDEF MSWINDOWS} + //not drain CPU on large downloads... + Sleep(0); + {$ENDIF} + x := WaitingData; + if x > 0 then + begin + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + {$IFDEF UNICODE} Result := TSynaBytes(buf); {$ELSE} Result := StringOf(buf); {$ENDIF} + end; + end + else + begin + if CanRead(Timeout) then + begin + x := WaitingData; + if x = 0 then + FLastError := WSAECONNRESET; + if x > 0 then + begin + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + {$IFDEF UNICODE} Result := TSynaBytes(buf); {$ELSE} Result := StringOf(buf); {$ENDIF} + end; + SetLength(Buf, 0); + end; + end + else + FLastError := WSAETIMEDOUT; + end; + end; + if FConvertLineEnd and (Result <> '') then + begin + if FLastCR and (Result[1] = LF) then + DeleteInternal(Result, 1, 1); + if FLastLF and (Result[1] = CR) then + DeleteInternal(Result, 1, 1); + FLastCR := False; + FLastLF := False; + end; + ExceptCheck; +end; + + +function TBlockSocket.RecvByte(Timeout: Integer): Byte; +begin + Result := 0; + ResetLastError; + if FBuffer = '' then + FBuffer := RecvPacket(Timeout); + if (FLastError = 0) and (FBuffer <> '') then + begin + Result := Ord(FBuffer[1]); + {$IFNDEF UNICODE} + Delete(FBuffer, 1, 1); + {$ELSE} + FBuffer.Delete(1, 1); // TEST! + {$ENDIF} + end; + ExceptCheck; +end; + +function TBlockSocket.RecvInteger(Timeout: Integer): Integer; +var + s: string; +begin + Result := 0; + s := RecvBufferStr(4, Timeout); + if FLastError = 0 then + Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; +end; + +function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string; +var + x: Integer; + s: TSynaBytes; + l: Integer; + CorCRLF: Boolean; + t: string; + tl: integer; + ti: LongWord; +begin + ResetLastError; + Result := ''; + l := Length(Terminator); + if l = 0 then + Exit; + tl := l; + CorCRLF := FConvertLineEnd and (Terminator = CRLF); + s := ''; + x := 0; + repeat + //get rest of FBuffer or incomming new data... + ti := GetTick; + s := s + RecvPacket(Timeout); + if FLastError <> 0 then + Break; + x := 0; + if s.Length > 0 then + if CorCRLF then + begin + t := ''; + x := PosCRLF(s, t); + tl := t.Length; + if t = CR then + FLastCR := True; + if t = LF then + FLastLF := True; + end + else + begin + x := pos(Terminator, s); + tl := l; + end; + if (FMaxLineLength <> 0) and (s.Length > FMaxLineLength) then + begin + FLastError := WSAENOBUFS; + Break; + end; + if x > 0 then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + FLastError := WSAETIMEDOUT; + Break; + end; + end; + until False; + if x > 0 then + begin + Result := Copy(s, 1, x - 1); + DeleteInternal(s, 1, x + tl - 1); + end; + FBuffer := s; + ExceptCheck; +end; + +function TBlockSocket.RecvString(Timeout: Integer): string; +var + s: string; +begin + Result := ''; + s := RecvTerminated(Timeout, CRLF); + if FLastError = 0 then + Result := s; +end; + +function TBlockSocket.RecvBlock(Timeout: Integer): string; +var + x: integer; +begin + Result := ''; + x := RecvInteger(Timeout); + if FLastError = 0 then + Result := RecvBufferStr(x, Timeout); +end; + +procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer); +var + s: string; +begin + repeat + s := RecvPacket(Timeout); + if FLastError = 0 then + WriteStrToStream(Stream, s); + until FLastError <> 0; +end; + +procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +var + s: TSynaBytes; + n: integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + for n := 1 to (Size div FSendMaxChunk) do + begin + {$IFDEF CIL} + SetLength(buf, FSendMaxChunk); + RecvBufferEx(buf, FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, FSendMaxChunk); + {$ELSE} + s := RecvBufferStr(FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + WriteStrToStream(Stream, s); + {$ENDIF} + end; + n := Size mod FSendMaxChunk; + if n > 0 then + begin + {$IFDEF CIL} + SetLength(buf, n); + RecvBufferEx(buf, n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, n); + {$ELSE} + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + WriteStrToStream(Stream, s); + {$ENDIF} + end; +end; + +procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + x := synsock.NToHL(x); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + {$IFNDEF CIL} +// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL); + SockCheck(Result); + ExceptCheck; + {$ENDIF} +end; + +function TBlockSocket.PeekByte(Timeout: Integer): Byte; +var + s: string; +begin + {$IFNDEF CIL} + Result := 0; + if CanRead(Timeout) then + begin + SetLength(s, 1); + PeekBuffer(Pointer(s), 1); + if s <> '' then + Result := Ord(s[1]); + end + else + FLastError := WSAETIMEDOUT; + ExceptCheck; + {$ENDIF} +end; + +procedure TBlockSocket.ResetLastError; +begin + FLastError := 0; + FLastErrorDesc := ''; +end; + +function TBlockSocket.SockCheck(SockResult: Integer): Integer; +begin + ResetLastError; + if SockResult = integer(SOCKET_ERROR) then + begin + FLastError := synsock.WSAGetLastError; + if FLastError <= WSABASEERR then + Inc(FLastError, WSABASEERR); + FLastErrorDesc := GetErrorDescEx; + end; + Result := FLastError; +end; + +procedure TBlockSocket.ExceptCheck; +var + e: ESynapseError; +begin + FLastErrorDesc := GetErrorDescEx; + if (LastError <> 0) and (LastError <> WSAEINPROGRESS) + and (LastError <> WSAEWOULDBLOCK) then + begin + DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); + FDisconnected := True; + if FRaiseExcept then + begin + if FLastError = 104 then + e := EResetByPeer.Create(Format('Synapse TCP/IP socket error. Reset by peer %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10098 then + e := ECouldNotBindSocket.Create(Format('Synapse TCP/IP socket error. Could not bind socket %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10054 then + e := EConnectionResetByPeer.Create(Format('Synapse TCP/IP socket error. Connection reset by peer %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10057 then + e := ESockectIsnotConnected.Create(Format('Synapse TCP/IP socket error. Socket is not connected %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10060 then + e := EConnectionTimedOut.Create(Format('Synapse TCP/IP socket error. Connection timed out %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10061 then + e := EConnectionRefused.Create(Format('Synapse TCP/IP socket error. Connection refused %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = 10049 then + e := ECantAssignAddress.Create(Format('Synapse TCP/IP socket error. Can''t assign requested address %d: %s', + [FLastError, FLastErrorDesc])) + else if FLastError = -2 then + e := ESocketMinus2.Create(Format('Synapse TCP/IP socket error %d: %s', + [FLastError, FLastErrorDesc])) + else e := ESynapseError.Create(Format('Synapse TCP/IP socket error %d: %s', + [FLastError, FLastErrorDesc])); + e.ErrorCode := FLastError; + e.ErrorMessage := FLastErrorDesc; + raise e; + end; + end; +end; + +function TBlockSocket.WaitingData: Integer; +var + x: Integer; +begin + Result := 0; + if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then + Result := x; + if Result > c64k then + Result := c64k; +end; + +function TBlockSocket.WaitingDataEx: Integer; +begin + if FBuffer <> '' then + Result := FBuffer.Length + else + Result := WaitingData; +end; + +procedure TBlockSocket.Purge; +begin + Sleep(1); + try + while (FBuffer.Length > 0) or (WaitingData > 0) do + begin + RecvPacket(0); + if FLastError <> 0 then + break; + end; + except + on exception do; + end; + ResetLastError; +end; + +procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_Linger; + d.Enabled := Enable; + d.Value := Linger; + DelayedOption(d); +end; + +function TBlockSocket.LocalName: string; +begin + Result := synsock.GetHostName; + if Result = '' then + Result := '127.0.0.1'; +end; + +procedure TBlockSocket.ResolveNameToIP(const Name: string; const IPList: + TStrings); +begin + IPList.Clear; + synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList); + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function TBlockSocket.ResolveName(const Name: string): string; +var + l: TStringList; +begin + l := TStringList.Create; + try + ResolveNameToIP(Name, l); + Result := l[0]; + finally + l.Free; + end; +end; + +function TBlockSocket.ResolvePort(const Port: string): Word; +begin + Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); +end; + +function TBlockSocket.ResolveIPToName(IP: string): string; +begin + if not IsIP(IP) and not IsIp6(IP) then + IP := ResolveName(IP); + Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); +end; + +procedure TBlockSocket.SetRemoteSin(const IP, Port: string); +begin + SetSin(FRemoteSin, IP, Port); +end; + +function TBlockSocket.GetLocalSinIP: string; +begin + Result := GetSinIP(FLocalSin); +end; + +function TBlockSocket.GetRecvTimeout: integer; +var + l: integer; +begin + l:=SizeOf(Integer); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @Result, l)); + ExceptCheck; +end; + +function TBlockSocket.GetRemoteSinIP: string; +begin + Result := GetSinIP(FRemoteSin); +end; + +function TBlockSocket.GetLocalSinPort: Integer; +begin + Result := GetSinPort(FLocalSin); +end; + +function TBlockSocket.GetRemoteSinPort: Integer; +begin + Result := GetSinPort(FRemoteSin); +end; + +function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); +{$ELSE} +var + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; + FDSet: TFDSet; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FDSet := FFdSet; + x := synsock.Select(integer(FSocket + 1), @FDSet, nil, nil, TimeVal); + SockCheck(x); + if FLastError <> 0 then + x := 0; + Result := x > 0; +{$ENDIF} +end; + +function TBlockSocket.CanRead(Timeout: Integer): Boolean; +var + ti, tr: Integer; + n: integer; +begin + if (FHeartbeatRate <> 0) and (Timeout <> -1) then + begin + ti := Timeout div FHeartbeatRate; + tr := Timeout mod FHeartbeatRate; + end + else + begin + ti := 0; + tr := Timeout; + end; + Result := InternalCanRead(tr); + if not Result then + for n := 0 to ti do + begin + DoHeartbeat; + if FStopFlag then + begin + Result := False; + FStopFlag := False; + Break; + end; + Result := InternalCanRead(FHeartbeatRate); + if Result then + break; + end; + ExceptCheck; + if Result then + DoStatus(HR_CanRead, ''); +end; + +function TBlockSocket.InternalCanWrite(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite); +{$ELSE} +var + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; + FDSet: TFDSet; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FDSet := FFdSet; + x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal); + SockCheck(x); + if FLastError <> 0 then + x := 0; + Result := x > 0; +{$ENDIF} +end; + +function TBlockSocket.CanWrite(Timeout: Integer): Boolean; +var + ti, tr: Integer; + n: integer; +begin + if (FHeartbeatRate <> 0) and (Timeout <> -1) then + begin + ti := Timeout div FHeartbeatRate; + tr := Timeout mod FHeartbeatRate; + end + else + begin + ti := 0; + tr := Timeout; + end; + Result := InternalCanWrite(tr); + if not Result then + for n := 0 to ti do + begin + DoHeartbeat; + if FStopFlag then + begin + Result := False; + FStopFlag := False; + Break; + end; + Result := InternalCanWrite(FHeartbeatRate); + if Result then + break; + end; + ExceptCheck; + if Result then + DoStatus(HR_CanWrite, ''); +end; + +function TBlockSocket.CanReadEx(Timeout: Integer): Boolean; +begin + if FBuffer <> '' then + Result := True + else + Result := CanRead(Timeout); +end; + +function TBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + DoMonitor(True, Buffer, Length); + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); + SockCheck(Result); + ExceptCheck; + Inc(FSendCounter, Result); + DoStatus(HR_WriteCount, IntToStr(Result)); +end; + +function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); + SockCheck(Result); + ExceptCheck; + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); +end; + +function TBlockSocket.GetSizeRecvBuffer: Integer; +var + l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l)); + if FLastError <> 0 then + Result := 1024; + ExceptCheck; +{$ENDIF} +end; + +procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_RecvBuff; + d.Value := Size; + DelayedOption(d); +end; + +function TBlockSocket.GetSizeSendBuffer: Integer; +var + l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} + l := SizeOf(Result); + SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l)); + if FLastError <> 0 then + Result := 1024; + ExceptCheck; +{$ENDIF} +end; + +procedure TBlockSocket.SetSizeSendBuffer(Size: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_SendBuff; + d.Value := Size; + DelayedOption(d); +end; + +procedure TBlockSocket.SetNagleMode(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_NoDelay; + d.Enabled := Value; + DelayedOption(d); +end; + +procedure TBlockSocket.SetNonBlockMode(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_nonblock; + d.Enabled := Value; + DelayedOption(d); +end; + +procedure TBlockSocket.SetTimeout(Timeout: Integer); +begin + SetSendTimeout(Timeout); + SetRecvTimeout(Timeout); +end; + +procedure TBlockSocket.SetSendTimeout(Timeout: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_sendtimeout; + d.Value := Timeout; + DelayedOption(d); +end; + +procedure TBlockSocket.SetRecvTimeout(Timeout: Integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_recvtimeout; + d.Value := Timeout; + DelayedOption(d); +end; + +{$IFNDEF CIL} +function TBlockSocket.GroupCanRead(const SocketList: TSocketList; Timeout: Integer; + const CanReadList: TSocketList): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x, n: Integer; + Max: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + FD_ZERO(FDSet); + Max := 0; + for n := 0 to SocketList.Count - 1 do + if TObject(SocketList.Items[n]) is TBlockSocket then + begin + if TBlockSocket(SocketList.Items[n]).Socket > Max then + Max := TBlockSocket(SocketList.Items[n]).Socket; + FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet); + end; + x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal); + SockCheck(x); + ExceptCheck; + if FLastError <> 0 then + x := 0; + Result := x > 0; + CanReadList.Clear; + if Result then + for n := 0 to SocketList.Count - 1 do + if TObject(SocketList.Items[n]) is TBlockSocket then + if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then + CanReadList.Add(TBlockSocket(SocketList.Items[n])); +end; +{$ENDIF} + +procedure TBlockSocket.EnableReuse(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_reuse; + d.Enabled := Value; + DelayedOption(d); +end; + +procedure TBlockSocket.SetTTL(TTL: integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_TTL; + d.Value := TTL; + DelayedOption(d); +end; + +function TBlockSocket.GetTTL:integer; +var + l: Integer; +begin +{$IFNDEF CIL} + l := SizeOf(Result); + if FIP6Used then + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l)) + else + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l)); + ExceptCheck; +{$ENDIF} +end; + +procedure TBlockSocket.SetFamily(Value: TSocketFamily); +begin + FFamily := Value; + FFamilySave := Value; +end; + +procedure TBlockSocket.SetSocket(Value: TSocket); +begin + FRecvCounter := 0; + FSendCounter := 0; + FSocket := Value; +{$IFNDEF CIL} + FD_ZERO(FFDSet); + FD_SET(FSocket, FFDSet); +{$ENDIF} + GetSins; + FIP6Used := FRemoteSin.AddressFamily = AF_INET6; +end; + +function TBlockSocket.GetWsaData: TWSAData; +begin + {$IFDEF ONCEWINSOCK} + Result := WsaDataOnce; + {$ELSE} + Result := FWsaDataOnce; + {$ENDIF} +end; + +function TBlockSocket.GetSocketType: integer; +begin + Result := 0; +end; + +function TBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_IP); +end; + +procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Reason, Value); + if Reason = HR_SocketClose then + FDisconnected := True; +end; + +procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer); +var + s: string; +begin + if assigned(OnReadFilter) then + if Len > 0 then + begin + {$IFDEF CIL} + s := StringOf(Buffer); + {$ELSE} + SetLength(s, Len); + Move(Buffer^, Pointer(s)^, Len); + {$ENDIF} + OnReadFilter(Self, s); + if s.Length > Len then + SetLength(s, Len); + Len := s.Length; + {$IFDEF CIL} + Buffer := BytesOf(s); + {$ELSE} + Move(Pointer(s)^, Buffer^, Len); + {$ENDIF} + end; +end; + +procedure TBlockSocket.DoCreateSocket; +begin + if assigned(OnCreateSocket) then + OnCreateSocket(Self); +end; + +procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); +begin + if assigned(OnMonitor) then + begin + OnMonitor(Self, Writing, Buffer, Len); + end; +end; + +procedure TBlockSocket.DoHeartbeat; +begin + if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then + begin + OnHeartbeat(Self); + end; +end; + +function TBlockSocket.GetErrorDescEx: string; +begin + Result := GetErrorDesc(FLastError); +end; + +class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; +begin +{$IFDEF CIL} + if ErrorCode = 0 then + Result := '' + else + begin + Result := WSAGetLastErrorDesc; + if Result = '' then + Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; + end; +{$ELSE} + case ErrorCode of + 0: + Result := ''; + WSAEINTR: {10004} + Result := 'Interrupted system call'; + WSAEBADF: {10009} + Result := 'Bad file number'; + WSAEACCES: {10013} + Result := 'Permission denied'; + WSAEFAULT: {10014} + Result := 'Bad address'; + WSAEINVAL: {10022} + Result := 'Invalid argument'; + WSAEMFILE: {10024} + Result := 'Too many open files'; + WSAEWOULDBLOCK: {10035} + Result := 'Operation would block'; + WSAEINPROGRESS: {10036} + Result := 'Operation now in progress'; + WSAEALREADY: {10037} + Result := 'Operation already in progress'; + WSAENOTSOCK: {10038} + Result := 'Socket operation on nonsocket'; + WSAEDESTADDRREQ: {10039} + Result := 'Destination address required'; + WSAEMSGSIZE: {10040} + Result := 'Message too long'; + WSAEPROTOTYPE: {10041} + Result := 'Protocol wrong type for Socket'; + WSAENOPROTOOPT: {10042} + Result := 'Protocol not available'; + WSAEPROTONOSUPPORT: {10043} + Result := 'Protocol not supported'; + WSAESOCKTNOSUPPORT: {10044} + Result := 'Socket not supported'; + WSAEOPNOTSUPP: {10045} + Result := 'Operation not supported on Socket'; + WSAEPFNOSUPPORT: {10046} + Result := 'Protocol family not supported'; + WSAEAFNOSUPPORT: {10047} + Result := 'Address family not supported'; + WSAEADDRINUSE: {10048} + Result := 'Address already in use'; + WSAEADDRNOTAVAIL: {10049} + Result := 'Can''t assign requested address'; + WSAENETDOWN: {10050} + Result := 'Network is down'; + WSAENETUNREACH: {10051} + Result := 'Network is unreachable'; + WSAENETRESET: {10052} + Result := 'Network dropped connection on reset'; + WSAECONNABORTED: {10053} + Result := 'Software caused connection abort'; + WSAECONNRESET: {10054} + Result := 'Connection reset by peer'; + WSAENOBUFS: {10055} + Result := 'No Buffer space available'; + WSAEISCONN: {10056} + Result := 'Socket is already connected'; + WSAENOTCONN: {10057} + Result := 'Socket is not connected'; + WSAESHUTDOWN: {10058} + Result := 'Can''t send after Socket shutdown'; + WSAETOOMANYREFS: {10059} + Result := 'Too many references:can''t splice'; + WSAETIMEDOUT: {10060} + Result := 'Connection timed out'; + WSAECONNREFUSED: {10061} + Result := 'Connection refused'; + WSAELOOP: {10062} + Result := 'Too many levels of symbolic links'; + WSAENAMETOOLONG: {10063} + Result := 'File name is too long'; + WSAEHOSTDOWN: {10064} + Result := 'Host is down'; + WSAEHOSTUNREACH: {10065} + Result := 'No route to host'; + WSAENOTEMPTY: {10066} + Result := 'Directory is not empty'; + WSAEPROCLIM: {10067} + Result := 'Too many processes'; + WSAEUSERS: {10068} + Result := 'Too many users'; + WSAEDQUOT: {10069} + Result := 'Disk quota exceeded'; + WSAESTALE: {10070} + Result := 'Stale NFS file handle'; + WSAEREMOTE: {10071} + Result := 'Too many levels of remote in path'; + WSASYSNOTREADY: {10091} + Result := 'Network subsystem is unusable'; + WSAVERNOTSUPPORTED: {10092} + Result := 'Winsock DLL cannot support this application'; + WSANOTINITIALISED: {10093} + Result := 'Winsock not initialized'; + WSAEDISCON: {10101} + Result := 'Disconnect'; + WSAHOST_NOT_FOUND: {11001} + Result := 'Host not found'; + WSATRY_AGAIN: {11002} + Result := 'Non authoritative - host not found'; + WSANO_RECOVERY: {11003} + Result := 'Non recoverable error'; + WSANO_DATA: {11004} + Result := 'Valid name, no data record of requested type' + else + Result := SysErrorMessage(ErrorCode) // 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; + end; +{$ENDIF} +end; + +{======================================================================} + +constructor TSocksBlockSocket.Create; +begin + inherited Create; + FSocksIP:= ''; + FSocksPort:= '1080'; + FSocksTimeout:= 60000; + FSocksUsername:= ''; + FSocksPassword:= ''; + FUsingSocks := False; + FSocksResolver := True; + FSocksLastError := 0; + FSocksResponseIP := ''; + FSocksResponsePort := ''; + FSocksLocalIP := ''; + FSocksLocalPort := ''; + FSocksRemoteIP := ''; + FSocksRemotePort := ''; + FBypassFlag := False; + FSocksType := ST_Socks5; +end; + +function TSocksBlockSocket.SocksOpen: boolean; +var + Buf: string; + n: integer; +begin + Result := False; + FUsingSocks := False; + if FSocksType <> ST_Socks5 then + begin + FUsingSocks := True; + Result := True; + end + else + begin + FBypassFlag := True; + try + if FSocksUsername = '' then + Buf := #5 + #1 + #0 + else + Buf := #5 + #2 + #2 +#0; + SendString(Buf); + Buf := RecvBufferStr(2, FSocksTimeout); + if Buf.Length < 2 then + Exit; + if Buf[1] <> #5 then + Exit; + n := Ord(Buf[2]); + case n of + 0: //not need authorisation + ; + 2: + begin + buf := #1 + Char(Length(FSocksUsername)) + FSocksUsername + + Char(Length(FSocksPassword)) + FSocksPassword; + SendString(Buf); + Buf := RecvBufferStr(2, FSocksTimeout); + if Length(Buf) < 2 then + Exit; + if Buf[2] <> #0 then + Exit; + end; + else + //other authorisation is not supported! + Exit; + end; + FUsingSocks := True; + Result := True; + finally + FBypassFlag := False; + end; + end; +end; + +function TSocksBlockSocket.SocksRequest(Cmd: Byte; + const IP, Port: string): Boolean; +var + buf: string; +begin + FBypassFlag := True; + try + if FSocksType <> ST_Socks5 then + Buf := #4 + Char(Cmd) + SocksCode(IP, Port) + else + Buf := #5 + Char(Cmd) + #0 + SocksCode(IP, Port); + SendString(Buf); + Result := FLastError = 0; + finally + FBypassFlag := False; + end; +end; + +function TSocksBlockSocket.SocksResponse: Boolean; +var + Buf, s, m, z: string; + x: integer; +begin + Result := False; + FBypassFlag := True; + try + FSocksResponseIP := ''; + FSocksResponsePort := ''; + FSocksLastError := -1; + if FSocksType <> ST_Socks5 then + begin + Buf := RecvBufferStr(8, FSocksTimeout); + if FLastError <> 0 then + Exit; + if Buf[1] <> #0 then + Exit; + FSocksLastError := Ord(Buf[2]); + end + else + begin + Buf := RecvBufferStr(4, FSocksTimeout); + if FLastError <> 0 then + Exit; + if Buf[1] <> #5 then + Exit; + case Ord(Buf[4]) of + 1: + s := RecvBufferStr(4, FSocksTimeout); + 3: + begin + x := RecvByte(FSocksTimeout); + if FLastError <> 0 then + Exit; + s := Char(x) + RecvBufferStr(x, FSocksTimeout); + end; + 4: + s := RecvBufferStr(16, FSocksTimeout); + else + Exit; + end; + Buf := Buf + s + RecvBufferStr(2, FSocksTimeout); + if FLastError <> 0 then + Exit; + FSocksLastError := Ord(Buf[2]); + end; + //--- + if ((FSocksLastError <> 0) and (FSocksLastError <> $5A{90})) then + begin + case FSocksLastError of // http://en.wikipedia.org/wiki/SOCKS + // v4 + $5a: m := 'request granted'; + $5b: m := 'request rejected or failed'; + $5c: m := 'request failed because client is not running identd (or not reachable from the server)'; + $5d: m := 'request failed because client''s identd could not confirm the user ID string in the request'; + // v5' + $00: m := 'request grant`ed'; + $01: m := 'general failure'; + $02: m := 'connection not allowed by ruleset'; + $03: m := 'network unreachable'; + $04: m := 'host unreachable'; + $05: m := 'connection refused by destination host'; + $06: m := 'TTL expired'; + $07: m := 'command not supported / protocol error'; + $08: m := 'address type not supported'; + else + m := ''; + end; + z := SysUtils.Format('Error 0x%x', [FSocksLastError]); + if m<>'' then + z := z + ' ' + m; + Exit; + end; + SocksDecode(Buf); + Result := True; + finally + FBypassFlag := False; + end; +end; + +function TSocksBlockSocket.SocksCode(IP: string; const Port: string): string; +var + ip6: TIp6Bytes; + n: integer; +begin + if FSocksType <> ST_Socks5 then + begin + Result := CodeInt(ResolvePort(Port)); + if not FSocksResolver then + IP := ResolveName(IP); + if IsIP(IP) then + begin + Result := Result + IPToID(IP); + Result := Result + FSocksUsername + #0; + end + else + begin + Result := Result + IPToID('0.0.0.1'); + Result := Result + FSocksUsername + #0; + Result := Result + IP + #0; + end; + end + else + begin + if not FSocksResolver then + IP := ResolveName(IP); + if IsIP(IP) then + Result := #1 + IPToID(IP) + else + if IsIP6(IP) then + begin + ip6 := StrToIP6(IP); + Result := #4; + for n := 0 to 15 do + Result := Result + Char(ip6[n]); + end + else + Result := #3 + Char(Length(IP)) + IP; + Result := Result + CodeInt(ResolvePort(Port)); + end; +end; + + function TSocksBlockSocket.SocksDecode(const Value: string): integer; +var + Atyp: Byte; + y, n: integer; + w: Word; + ip6: TIp6Bytes; +begin + FSocksResponsePort := '0'; + Result := 0; + if FSocksType <> ST_Socks5 then + begin + if Length(Value) < 8 then + Exit; + Result := 3; + w := DecodeInt(Value, Result); + FSocksResponsePort := IntToStr(w); + FSocksResponseIP := Format('%d.%d.%d.%d', + [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); + Result := 9; + end + else + begin + if Length(Value) < 4 then + Exit; + Atyp := Ord(Value[4]); + Result := 5; + case Atyp of + 1: + begin + if Length(Value) < 10 then + Exit; + FSocksResponseIP := Format('%d.%d.%d.%d', + [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); + Result := 9; + end; + 3: + begin + y := Ord(Value[5]); + if Length(Value) < (5 + y + 2) then + Exit; + for n := 6 to 6 + y - 1 do + FSocksResponseIP := FSocksResponseIP + Value[n]; + Result := 5 + y + 1; + end; + 4: + begin + if Length(Value) < 22 then + Exit; + for n := 0 to 15 do + ip6[n] := ord(Value[n + 5]); + FSocksResponseIP := IP6ToStr(ip6); + Result := 21; + end; + else + Exit; + end; + w := DecodeInt(Value, Result); + FSocksResponsePort := IntToStr(w); + Result := Result + 2; + end; +end; + +{======================================================================} + +procedure TDgramBlockSocket.Connect(const IP, Port: string); +begin + SetRemoteSin(IP, Port); + InternalCreateSocket(FRemoteSin); + if UseConnect then + begin + SockCheck(synsock.Connect(FSocket, FRemoteSin)); + if FLastError = 0 then + GetSins; + end; + FBuffer := ''; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := RecvBufferFrom(Buffer, Length); +end; + +function TDgramBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; +begin + Result := SendBufferTo(Buffer, Length); +end; + +{======================================================================} + +destructor TUDPBlockSocket.Destroy; +begin + if Assigned(FSocksControlSock) then + FSocksControlSock.Free; + inherited; +end; + +procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_Broadcast; + d.Enabled := Value; + DelayedOption(d); +end; + +function TUDPBlockSocket.UdpAssociation: Boolean; +var + b: Boolean; +begin + Result := True; + FUsingSocks := False; + if FSocksIP <> '' then + begin + Result := False; + if not Assigned(FSocksControlSock) then + FSocksControlSock := TTCPBlockSocket.Create; + FSocksControlSock.CloseSocket; + FSocksControlSock.CreateSocketByName(FSocksIP); + FSocksControlSock.Connect(FSocksIP, FSocksPort); + if FSocksControlSock.LastError <> 0 then + Exit; + // if not assigned local port, assign it! + if not FBinded then + Bind(cAnyHost, cAnyPort); + //open control TCP connection to SOCKS + FSocksControlSock.FSocksUsername := FSocksUsername; + FSocksControlSock.FSocksPassword := FSocksPassword; + b := FSocksControlSock.SocksOpen; + if b then + b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); + if b then + b := FSocksControlSock.SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FUsingSocks :=FSocksControlSock.UsingSocks; + FSocksRemoteIP := FSocksControlSock.FSocksResponseIP; + FSocksRemotePort := FSocksControlSock.FSocksResponsePort; + Result := b and (FLastError = 0); + end; +end; + +function TUDPBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; +var + SIp: string; + SPort: integer; + Buf: string; +begin + Result := 0; + FUsingSocks := False; + if (FSocksIP <> '') and (not UdpAssociation) then + FLastError := WSANO_RECOVERY + else + begin + if FUsingSocks then + begin +{$IFNDEF CIL} + Sip := GetRemoteSinIp; + SPort := GetRemoteSinPort; + SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); + SetLength(Buf,Length); + Move(Buffer^, Pointer(Buf)^, Length); + Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; + Result := inherited SendBufferTo(Pointer(Buf), buf.Length); + SetRemoteSin(Sip, IntToStr(SPort)); +{$ENDIF} + end + else + Result := inherited SendBufferTo(Buffer, Length); + end; +end; + +function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; +var + Buf: string; + x: integer; +begin + Result := inherited RecvBufferFrom(Buffer, Length); + if FUsingSocks then + begin +{$IFNDEF CIL} + SetLength(Buf, Result); + Move(Buffer^, Pointer(Buf)^, Result); + x := SocksDecode(Buf); + Result := Result - x + 1; + Buf := Copy(Buf, x, Result); + Move(Pointer(Buf)^, Buffer^, Result); + SetRemoteSin(FSocksResponseIP, FSocksResponsePort); +{$ENDIF} + end; +end; + +{$IFNDEF CIL} +procedure TUDPBlockSocket.AddMulticast(const MCastIP:string); +var + Multicast: TIP_mreq; + Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; +begin + if FIP6Used then + begin + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do +{$IFNDEF POSIX} + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; +{$ELSE} + Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n]; +{$ENDIF} + Multicast6.ipv6mr_interface := 0; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, + Pointer(@Multicast6), SizeOf(Multicast6))); + end + else + begin + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); +// Multicast.imr_interface.S_addr := INADDR_ANY; + Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, + Pointer(@Multicast), SizeOf(Multicast))); + end; + ExceptCheck; +end; + +procedure TUDPBlockSocket.DropMulticast(const MCastIP:string); +var + Multicast: TIP_mreq; + Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; +begin + if FIP6Used then + begin + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do +{$IFNDEF POSIX} + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; +{$ELSE} + Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n]; +{$ENDIF} + + Multicast6.ipv6mr_interface := 0; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, + Pointer(@Multicast6), SizeOf(Multicast6))); + end + else + begin + Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); +// Multicast.imr_interface.S_addr := INADDR_ANY; + Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr; + SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, + Pointer(@Multicast), SizeOf(Multicast))); + end; + ExceptCheck; +end; +{$ENDIF} + +procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_MulticastTTL; + d.Value := TTL; + DelayedOption(d); +end; + +function TUDPBlockSocket.GetMulticastTTL:integer; +var + l: Integer; +begin +{$IFNDEF CIL} + l := SizeOf(Result); + if FIP6Used then + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l)) + else + SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l)); + ExceptCheck; +{$ENDIF} +end; + +procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean); +var + d: TSynaOption; +begin + d := TSynaOption.Create; + d.Option := SOT_MulticastLoop; + d.Enabled := Value; + DelayedOption(d); +end; + +function TUDPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_DGRAM); +end; + +function TUDPBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_UDP); +end; + +{======================================================================} +constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass); +begin + inherited Create; + FSSL := SSLPlugin.Create(self); + FHTTPTunnelIP := ''; + FHTTPTunnelPort := ''; + FHTTPTunnel := False; + FHTTPTunnelRemoteIP := ''; + FHTTPTunnelRemotePort := ''; + FHTTPTunnelUser := ''; + FHTTPTunnelPass := ''; + FHTTPTunnelTimeout := 30000; +end; + +constructor TTCPBlockSocket.Create; +begin + CreateWithSSL(SSLImplementation); +end; + +destructor TTCPBlockSocket.Destroy; +begin + inherited Destroy; + FSSL.Free; +end; + +function TTCPBlockSocket.GetErrorDescEx: string; +begin + Result := inherited GetErrorDescEx; + if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then + begin + Result := self.SSL.LastErrorDesc; + end; +end; + +const + SHUT_RDWR = 2; + +procedure TTCPBlockSocket.CloseSocket; +begin + if FSSL.SSLEnabled then + FSSL.Shutdown; + if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then + begin + SockCheck(Synsock.Shutdown(FSocket, SHUT_RDWR)); + //ExceptCheck; + Purge; + SetLinger(True, 0); + end; + inherited CloseSocket; +end; + +procedure TTCPBlockSocket.DoAfterConnect; +begin + if Assigned(OnAfterConnect) then + begin + OnAfterConnect(Self); + end; +end; + +function TTCPBlockSocket.WaitingData: Integer; +begin + Result := 0; + if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then + Result := FSSL.WaitingData; + if Result = 0 then + Result := inherited WaitingData; +end; + +procedure TTCPBlockSocket.Listen; +var + b: Boolean; + Sip,SPort: string; +begin + if FSocksIP = '' then + begin + inherited Listen; + end + else + begin + Sip := GetLocalSinIP; + if Sip = cAnyHost then + Sip := LocalName; + SPort := IntToStr(GetLocalSinPort); + inherited Connect(FSocksIP, FSocksPort); + b := SocksOpen; + if b then + b := SocksRequest(2, Sip, SPort); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FSocksLocalIP := FSocksResponseIP; + if FSocksLocalIP = cAnyHost then + FSocksLocalIP := FSocksIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := ''; + FSocksRemotePort := ''; + ExceptCheck; + DoStatus(HR_Listen, ''); + end; +end; + +function TTCPBlockSocket.Accept: TSocket; +begin + if FUsingSocks then + begin + if not SocksResponse and (FLastError = 0) then + FLastError := WSANO_RECOVERY; + FSocksRemoteIP := FSocksResponseIP; + FSocksRemotePort := FSocksResponsePort; + Result := FSocket; + ExceptCheck; + DoStatus(HR_Accept, ''); + end + else + begin + result := inherited Accept; + end; +end; + +procedure TTCPBlockSocket.Connect(const IP, Port: string); +begin + FDisconnected := False; + if FSocksIP <> '' then + SocksDoConnect(IP, Port) + else + if FHTTPTunnelIP <> '' then + HTTPTunnelDoConnect(IP, Port) + else + inherited Connect(IP, Port); + if FLasterror = 0 then + DoAfterConnect; +end; + +function TTCPBlockSocket.Connected: boolean; +begin + Result := (FSocket <> INVALID_SOCKET) and not FDisconnected; + {$IFNDEF UNIX} + if Result then + begin + CanRead(0); + Result := not FDisconnected; + end; + {$ENDIF} +end; + +procedure TTCPBlockSocket.SocksDoConnect(const IP, Port: string); +var + b: Boolean; +begin + inherited Connect(FSocksIP, FSocksPort); + if FLastError = 0 then + begin + b := SocksOpen; + if b then + b := SocksRequest(1, IP, Port); + if b then + b := SocksResponse; + if not b and (FLastError = 0) then + FLastError := WSASYSNOTREADY; + FSocksLocalIP := FSocksResponseIP; + FSocksLocalPort := FSocksResponsePort; + FSocksRemoteIP := IP; + FSocksRemotePort := Port; + end; + ExceptCheck; + DoStatus(HR_Connect, IP + ':' + Port); +end; + +procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); +//bugfixed by Mike Green (mgreen@emixode.com) +var + s: string; +begin + Port := IntToStr(ResolvePort(Port)); + inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); + if FLastError <> 0 then + Exit; + FHTTPTunnel := False; + if IsIP6(IP) then + IP := '[' + IP + ']'; + SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); + if FHTTPTunnelUser <> '' then + Sendstring('Proxy-Authorization: Basic ' + + EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); + SendString(CRLF); + repeat + s := RecvTerminated(FHTTPTunnelTimeout, #$0a); + if FLastError <> 0 then + Break; + if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then + FHTTPTunnel := s[10] = '2'; + until (s = '') or (s = #$0d); + if (FLasterror = 0) and not FHTTPTunnel then + FLastError := WSAECONNREFUSED; + FHTTPTunnelRemoteIP := IP; + FHTTPTunnelRemotePort := Port; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoConnect; +begin + ResetLastError; + if not FSSL.Connect then + FLastError := WSASYSNOTREADY; + ExceptCheck; +end; + +procedure TTCPBlockSocket.SSLDoShutdown; +begin + ResetLastError; + FSSL.BiShutdown; +end; + +function TTCPBlockSocket.GetLocalSinIP: string; +begin + if FUsingSocks then + Result := FSocksLocalIP + else + Result := inherited GetLocalSinIP; +end; + +function TTCPBlockSocket.GetRemoteSinIP: string; +begin + if FUsingSocks then + Result := FSocksRemoteIP + else + if FHTTPTunnel then + Result := FHTTPTunnelRemoteIP + else + Result := inherited GetRemoteSinIP; +end; + +function TTCPBlockSocket.GetLocalSinPort: Integer; +begin + if FUsingSocks then + Result := StrToIntDef(FSocksLocalPort, 0) + else + Result := inherited GetLocalSinPort; +end; + +function TTCPBlockSocket.GetRemoteSinPort: Integer; +begin + if FUsingSocks then + Result := ResolvePort(FSocksRemotePort) + else + if FHTTPTunnel then + Result := StrToIntDef(FHTTPTunnelRemotePort, 0) + else + Result := inherited GetRemoteSinPort; +end; + +function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + if FSSL.SSLEnabled then + begin + Result := 0; + if TestStopFlag then + Exit; + ResetLastError; + LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv); + Result := FSSL.RecvBuffer(Buffer, Len); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + ExceptCheck; + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); + DoReadFilter(Buffer, Result); + end + else + Result := inherited RecvBuffer(Buffer, Len); +end; + +function TTCPBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; +var + x, y: integer; + l, r: integer; +{$IFNDEF CIL} + p: Pointer; +{$ENDIF} +begin + if FSSL.SSLEnabled then + begin + Result := 0; + if TestStopFlag then + Exit; + ResetLastError; + DoMonitor(True, Buffer, Length); +{$IFDEF CIL} + Result := FSSL.SendBuffer(Buffer, Length); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + Inc(FSendCounter, Result); + DoStatus(HR_WriteCount, IntToStr(Result)); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); + r := FSSL.SendBuffer(p, y); + if FSSL.LastError <> 0 then + FLastError := WSASYSNOTREADY; + if Flasterror <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} + ExceptCheck; + end + else + Result := inherited SendBuffer(Buffer, Length); +end; + +function TTCPBlockSocket.SSLAcceptConnection: Boolean; +begin + ResetLastError; + if not FSSL.Accept then + FLastError := WSASYSNOTREADY; + ExceptCheck; + Result := FLastError = 0; +end; + +function TTCPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_STREAM); +end; + +function TTCPBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_TCP); +end; + +{======================================================================} + +function TICMPBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RAW); +end; + +function TICMPBlockSocket.GetSocketProtocol: integer; +begin + if FIP6Used then + Result := integer(IPPROTO_ICMPV6) + else + Result := integer(IPPROTO_ICMP); +end; + +{======================================================================} + +function TRAWBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RAW); +end; + +function TRAWBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RAW); +end; + +{======================================================================} + +function TPGMmessageBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_RDM); +end; + +function TPGMmessageBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RM); +end; + +{======================================================================} + +function TPGMstreamBlockSocket.GetSocketType: integer; +begin + Result := integer(SOCK_STREAM); +end; + +function TPGMstreamBlockSocket.GetSocketProtocol: integer; +begin + Result := integer(IPPROTO_RM); +end; + +{======================================================================} + +constructor TSynaClient.Create; +begin + inherited Create; + FIPInterface := cAnyHost; + FTargetHost := cLocalhost; + FTargetPort := cAnyPort; + FTimeout := 5000; + FUsername := ''; + FPassword := ''; +end; + +{======================================================================} + +constructor TCustomSSL.Create(const Value: TTCPBlockSocket); +begin + inherited Create; + FSocket := Value; + FSSLEnabled := False; + FUsername := ''; + FPassword := ''; + FLastError := 0; + FLastErrorDesc := ''; + FVerifyCert := False; + FSSLType := LT_all; + FKeyPassword := ''; + FCiphers := ''; + FCertificateFile := ''; + FPrivateKeyFile := ''; + FCertCAFile := ''; + FCertCA := ''; + FTrustCertificate := ''; + FTrustCertificateFile := ''; + FCertificate := ''; + FPrivateKey := ''; + FPFX := ''; + FPFXfile := ''; + FSSHChannelType := ''; + FSSHChannelArg1 := ''; + FSSHChannelArg2 := ''; + FCertComplianceLevel := -1; //default + FSNIHost := ''; +end; + +procedure TCustomSSL.Assign(const Value: TCustomSSL); +begin + FUsername := Value.Username; + FPassword := Value.Password; + FVerifyCert := Value.VerifyCert; + FSSLType := Value.SSLType; + FKeyPassword := Value.KeyPassword; + FCiphers := Value.Ciphers; + FCertificateFile := Value.CertificateFile; + FPrivateKeyFile := Value.PrivateKeyFile; + FCertCAFile := Value.CertCAFile; + FCertCA := Value.CertCA; + FTrustCertificate := Value.TrustCertificate; + FTrustCertificateFile := Value.TrustCertificateFile; + FCertificate := Value.Certificate; + FPrivateKey := Value.PrivateKey; + FPFX := Value.PFX; + FPFXfile := Value.PFXfile; + FCertComplianceLevel := Value.CertComplianceLevel; + FSNIHost := Value.FSNIHost; +end; + +procedure TCustomSSL.ReturnError; +begin + FLastError := -1; + FLastErrorDesc := 'SSL/TLS support is not compiled!'; +end; + +function TCustomSSL.LibVersion: string; +begin + Result := ''; +end; + +function TCustomSSL.LibName: string; +begin + Result := ''; +end; + +function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean; +begin + Result := False; +end; + +function TCustomSSL.Connect: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Accept: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.Shutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.BiShutdown: boolean; +begin + ReturnError; + Result := False; +end; + +function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +procedure TCustomSSL.SetCertCAFile(const Value: string); +begin + FCertCAFile := Value; +end; + +function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + ReturnError; + Result := integer(SOCKET_ERROR); +end; + +function TCustomSSL.WaitingData: Integer; +begin + ReturnError; + Result := 0; +end; + +function TCustomSSL.GetSSLVersion: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerSubject: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerSerialNo: integer; +begin + Result := -1; +end; + +function TCustomSSL.GetPeerName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerNameHash: cardinal; +begin + Result := 0; +end; + +function TCustomSSL.GetPeerIssuer: string; +begin + Result := ''; +end; + +function TCustomSSL.GetPeerFingerprint: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCertInfo: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherName: string; +begin + Result := ''; +end; + +function TCustomSSL.GetCipherBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetCipherAlgBits: integer; +begin + Result := 0; +end; + +function TCustomSSL.GetVerifyCert: integer; +begin + Result := 1; +end; + +function TCustomSSL.DoVerifyCert:boolean; +begin + if assigned(OnVerifyCert) then + begin + result:=OnVerifyCert(Self); + end + else + result:=true; +end; + + +{======================================================================} + +function TSSLNone.LibVersion: string; +begin + Result := 'Without SSL support'; +end; + +function TSSLNone.LibName: string; +begin + Result := 'ssl_none'; +end; + +{======================================================================} + +initialization +begin +{$IFDEF ONCEWINSOCK} + if not InitSocketInterface(DLLStackName) then + begin + e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!'); + e.ErrorCode := 0; + e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!'; + raise e; + end; + synsock.WSAStartup(WinsockLevel, WsaDataOnce); +{$ENDIF} +end; + +finalization +begin +{$IFDEF ONCEWINSOCK} + synsock.WSACleanup; + DestroySocketInterface; +{$ENDIF} +end; + +end. diff --git a/clamsend.pas b/clamsend.pas new file mode 100644 index 0000000..08a8864 --- /dev/null +++ b/clamsend.pas @@ -0,0 +1,277 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.001 | +|==============================================================================| +| Content: ClamAV-daemon client | +|==============================================================================| +| Copyright (c)2005-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2005-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract( ClamAV-daemon client) + +This unit is capable to do antivirus scan of your data by TCP channel to ClamD +daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit clamsend; + +interface + +uses + SysUtils, Classes, + synsock, blcksock, synautil; + +const + cClamProtocol = '3310'; + +type + + {:@abstract(Implementation of ClamAV-daemon client protocol) + By this class you can scan any your data by ClamAV opensource antivirus. + + This class can connect to ClamD by TCP channel, send your data to ClamD + and read result.} + TClamSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FDSock: TTCPBlockSocket; + FSession: boolean; + function Login: boolean; virtual; + function Logout: Boolean; virtual; + function OpenStream: Boolean; virtual; + public + constructor Create; + destructor Destroy; override; + + {:Call any command to ClamD. Used internally by other methods.} + function DoCommand(const Value: AnsiString): AnsiString; virtual; + + {:Return ClamAV version and version of loaded databases.} + function GetVersion: AnsiString; virtual; + + {:Scan content of TStrings.} + function ScanStrings(const Value: TStrings): AnsiString; virtual; + + {:Scan content of TStream.} + function ScanStream(const Value: TStream): AnsiString; virtual; + + {:Scan content of TStrings by new 0.95 API.} + function ScanStrings2(const Value: TStrings): AnsiString; virtual; + + {:Scan content of TStream by new 0.95 API.} + function ScanStream2(const Value: TStream): AnsiString; virtual; + published + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} + property DSock: TTCPBlockSocket read FDSock; + + {:Can turn-on session mode of communication with ClamD. Default is @false, + because ClamAV developers design their TCP code very badly and session mode + is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs + and this mode will be possible in future.} + property Session: boolean read FSession write FSession; + end; + +implementation + +constructor TClamSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FDSock := TTCPBlockSocket.Create; + FDSock.Owner := self; + FTimeout := 60000; + FTargetPort := cClamProtocol; + FSession := false; +end; + +destructor TClamSend.Destroy; +begin + Logout; + FDSock.Free; + FSock.Free; + inherited Destroy; +end; + +function TClamSend.DoCommand(const Value: AnsiString): AnsiString; +begin + Result := ''; + if not FSession then + FSock.CloseSocket + else + FSock.SendString(Value + LF); + if not FSession or (FSock.LastError <> 0) then + begin + if Login then + FSock.SendString(Value + LF) + else + Exit; + end; + Result := FSock.RecvTerminated(FTimeout, LF); +end; + +function TClamSend.Login: boolean; +begin + Result := False; + Sock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError <> 0 then + Exit; + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError <> 0 then + Exit; + if FSession then + FSock.SendString('SESSION' + LF); + Result := FSock.LastError = 0; +end; + +function TClamSend.Logout: Boolean; +begin + FSock.SendString('END' + LF); + Result := FSock.LastError = 0; + FSock.CloseSocket; +end; + +function TClamSend.GetVersion: AnsiString; +begin + Result := DoCommand('nVERSION'); +end; + +function TClamSend.OpenStream: Boolean; +var + S: AnsiString; +begin + Result := False; + s := DoCommand('nSTREAM'); + if (s <> '') and (Copy(s, 1, 4) = 'PORT') then + begin + s := SeparateRight(s, ' '); + FDSock.CloseSocket; + FDSock.Bind(FIPInterface, cAnyPort); + if FDSock.LastError <> 0 then + Exit; + FDSock.Connect(FTargetHost, s); + if FDSock.LastError <> 0 then + Exit; + Result := True; + end; +end; + +function TClamSend.ScanStrings(const Value: TStrings): AnsiString; +begin + Result := ''; + if OpenStream then + begin + DSock.SendString(Value.Text); + DSock.CloseSocket; + Result := FSock.RecvTerminated(FTimeout, LF); + end; +end; + +function TClamSend.ScanStream(const Value: TStream): AnsiString; +begin + Result := ''; + if OpenStream then + begin + DSock.SendStreamRaw(Value); + DSock.CloseSocket; + Result := FSock.RecvTerminated(FTimeout, LF); + end; +end; + +function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; +var + i: integer; + s: AnsiString; +begin + Result := ''; + if not FSession then + FSock.CloseSocket + else + FSock.sendstring('nINSTREAM' + LF); + if not FSession or (FSock.LastError <> 0) then + begin + if Login then + FSock.sendstring('nINSTREAM' + LF) + else + Exit; + end; + s := Value.text; + i := length(s); + FSock.SendString(CodeLongint(i) + s + #0#0#0#0); + Result := FSock.RecvTerminated(FTimeout, LF); +end; + +function TClamSend.ScanStream2(const Value: TStream): AnsiString; +var + i: integer; +begin + Result := ''; + if not FSession then + FSock.CloseSocket + else + FSock.sendstring('nINSTREAM' + LF); + if not FSession or (FSock.LastError <> 0) then + begin + if Login then + FSock.sendstring('nINSTREAM' + LF) + else + Exit; + end; + i := value.Size; + FSock.SendString(CodeLongint(i)); + FSock.SendStreamRaw(Value); + FSock.SendString(#0#0#0#0); + Result := FSock.RecvTerminated(FTimeout, LF); +end; + +end. diff --git a/dnssend.pas b/dnssend.pas new file mode 100644 index 0000000..cbf7d3b --- /dev/null +++ b/dnssend.pas @@ -0,0 +1,603 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.007.006 | +|==============================================================================| +| Content: DNS client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} +{: @abstract(DNS client by UDP or TCP) +Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone + transfers too! + +Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit dnssend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synaip, synsock; + +const + cDnsProtocol = '53'; + + QTYPE_A = 1; + QTYPE_NS = 2; + QTYPE_MD = 3; + QTYPE_MF = 4; + QTYPE_CNAME = 5; + QTYPE_SOA = 6; + QTYPE_MB = 7; + QTYPE_MG = 8; + QTYPE_MR = 9; + QTYPE_NULL = 10; + QTYPE_WKS = 11; // + QTYPE_PTR = 12; + QTYPE_HINFO = 13; + QTYPE_MINFO = 14; + QTYPE_MX = 15; + QTYPE_TXT = 16; + + QTYPE_RP = 17; + QTYPE_AFSDB = 18; + QTYPE_X25 = 19; + QTYPE_ISDN = 20; + QTYPE_RT = 21; + QTYPE_NSAP = 22; + QTYPE_NSAPPTR = 23; + QTYPE_SIG = 24; // RFC-2065 + QTYPE_KEY = 25; // RFC-2065 + QTYPE_PX = 26; + QTYPE_GPOS = 27; + QTYPE_AAAA = 28; + QTYPE_LOC = 29; // RFC-1876 + QTYPE_NXT = 30; // RFC-2065 + + QTYPE_SRV = 33; + QTYPE_NAPTR = 35; // RFC-2168 + QTYPE_KX = 36; + QTYPE_SPF = 99; + + QTYPE_AXFR = 252; + QTYPE_MAILB = 253; // + QTYPE_MAILA = 254; // + QTYPE_ALL = 255; + +type + {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TDNSSend = class(TSynaClient) + private + FID: Word; + FRCode: Integer; + FBuffer: AnsiString; + FSock: TUDPBlockSocket; + FTCPSock: TTCPBlockSocket; + FUseTCP: Boolean; + FAnswerInfo: TStringList; + FNameserverInfo: TStringList; + FAdditionalInfo: TStringList; + FAuthoritative: Boolean; + FTruncated: Boolean; + function CompressName(const Value: AnsiString): AnsiString; + function CodeHeader: AnsiString; + function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; + function DecodeLabels(var From: Integer): AnsiString; + function DecodeString(var From: Integer): AnsiString; + function DecodeResource(var i: Integer; const Info: TStringList; + QType: Integer): AnsiString; + function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; + function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; + QType: Integer):boolean; + public + constructor Create; + destructor Destroy; override; + + {:Query a DNSHost for QType resources correspond to a name. Supported QType + values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA, + Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO, + Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25, + Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS, + Qtype_KX. + + Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode! + + "Name" is domain name or host name for queried resource. If "name" is + IP address, automatically convert to reverse domain form (.in-addr.arpa). + + If result is @true, Reply contains resource records. One record on one line. + If Resource record have multiple fields, they are stored on line divided by + comma. (example: MX record contains value 'rs.cesnet.cz' with preference + number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address + in resource are converted to string form.} + function DNSQuery(Name: AnsiString; QType: Integer; + const Reply: TStrings): Boolean; + published + + {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.} + property Sock: TUDPBlockSocket read FSock; + + {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.} + property TCPSock: TTCPBlockSocket read FTCPSock; + + {:if @true, then is used TCP protocol instead UDP. It is needed for zone + transfers, etc.} + property UseTCP: Boolean read FUseTCP Write FUseTCP; + + {:After DNS operation contains ResultCode of DNS operation. + Values are: 0-no error, 1-format error, 2-server failure, 3-name error, + 4-not implemented, 5-refused.} + property RCode: Integer read FRCode; + + {:@True, if answer is authoritative.} + property Authoritative: Boolean read FAuthoritative; + + {:@True, if answer is truncated to 512 bytes.} + property Truncated: Boolean read FTRuncated; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed information about query reply.} + property AnswerInfo: TStringList read FAnswerInfo; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed information about nameserver.} + property NameserverInfo: TStringList read FNameserverInfo; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed additional information.} + property AdditionalInfo: TStringList read FAdditionalInfo; + end; + +{:A very useful function, and example of it's use is found in the TDNSSend object. + This function is used to get mail servers for a domain and sort them by + preference numbers. "Servers" contains only the domain names of the mail + servers in the right order (without preference number!). The first domain name + will always be the highest preferenced mail server. Returns boolean @TRUE if + all went well.} +function GetMailServers(const DNSHost, Domain: AnsiString; + const Servers: TStrings): Boolean; + +implementation + +constructor TDNSSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTCPSock := TTCPBlockSocket.Create; + FTCPSock.Owner := self; + FUseTCP := False; + FTimeout := 10000; + FTargetPort := cDnsProtocol; + FAnswerInfo := TStringList.Create; + FNameserverInfo := TStringList.Create; + FAdditionalInfo := TStringList.Create; + Randomize; +end; + +destructor TDNSSend.Destroy; +begin + FAnswerInfo.Free; + FNameserverInfo.Free; + FAdditionalInfo.Free; + FTCPSock.Free; + FSock.Free; + inherited Destroy; +end; + +function TDNSSend.CompressName(const Value: AnsiString): AnsiString; +var + n: Integer; + s: AnsiString; +begin + Result := ''; + if Value = '' then + Result := #0 + else + begin + s := ''; + for n := 1 to Length(Value) do + if Value[n] = '.' then + begin + Result := Result + AnsiChar(Length(s)) + s; + s := ''; + end + else + s := s + Value[n]; + if s <> '' then + Result := Result + AnsiChar(Length(s)) + s; + Result := Result + #0; + end; +end; + +function TDNSSend.CodeHeader: AnsiString; +begin + FID := Random(32767); + Result := CodeInt(FID); // ID + Result := Result + CodeInt($0100); // flags + Result := Result + CodeInt(1); // QDCount + Result := Result + CodeInt(0); // ANCount + Result := Result + CodeInt(0); // NSCount + Result := Result + CodeInt(0); // ARCount +end; + +function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; +begin + Result := CompressName(Name); + Result := Result + CodeInt(QType); + Result := Result + CodeInt(1); // Type INTERNET +end; + +function TDNSSend.DecodeString(var From: Integer): AnsiString; +var + Len: integer; +begin + Len := Ord(FBuffer[From]); + Inc(From); + Result := Copy(FBuffer, From, Len); + Inc(From, Len); +end; + +function TDNSSend.DecodeLabels(var From: Integer): AnsiString; +var + l, f: Integer; +begin + Result := ''; + while True do + begin + if From >= Length(FBuffer) then + Break; + l := Ord(FBuffer[From]); + Inc(From); + if l = 0 then + Break; + if Result <> '' then + Result := Result + '.'; + if (l and $C0) = $C0 then + begin + f := l and $3F; + f := f * 256 + Ord(FBuffer[From]) + 1; + Inc(From); + Result := Result + DecodeLabels(f); + Break; + end + else + begin + Result := Result + Copy(FBuffer, From, l); + Inc(From, l); + end; + end; +end; + +function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; + QType: Integer): AnsiString; +var + Rname: AnsiString; + RType, Len, j, x, y, z, n: Integer; + R: AnsiString; + t1, t2, ttl: integer; + ip6: TIp6bytes; +begin + Result := ''; + R := ''; + Rname := DecodeLabels(i); + RType := DecodeInt(FBuffer, i); + Inc(i, 4); + t1 := DecodeInt(FBuffer, i); + Inc(i, 2); + t2 := DecodeInt(FBuffer, i); + Inc(i, 2); + ttl := t1 * 65536 + t2; + Len := DecodeInt(FBuffer, i); + Inc(i, 2); // i point to begin of data + j := i; + i := i + len; // i point to next record + if Length(FBuffer) >= (i - 1) then + case RType of + QTYPE_A: + begin + R := IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + Inc(j); + R := R + '.' + IntToStr(Ord(FBuffer[j])); + end; + QTYPE_AAAA: + begin + for n := 0 to 15 do + ip6[n] := ord(FBuffer[j + n]); + R := IP6ToStr(ip6); + end; + QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, + QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, + QTYPE_NSAPPTR: + R := DecodeLabels(j); + QTYPE_SOA: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + for n := 1 to 5 do + begin + x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); + Inc(j, 4); + R := R + ',' + IntToStr(x); + end; + end; + QTYPE_NULL: + begin + end; + QTYPE_WKS: + begin + end; + QTYPE_HINFO: + begin + R := DecodeString(j); + R := R + ',' + DecodeString(j); + end; + QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_TXT, QTYPE_SPF: + begin + R := ''; + while j < i do + R := R + DecodeString(j); + end; + QTYPE_GPOS: + begin + R := DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_PX: + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); + R := R + ',' + DecodeLabels(j); + R := R + ',' + DecodeLabels(j); + end; + QTYPE_SRV: + // Author: Dan + begin + x := DecodeInt(FBuffer, j); + Inc(j, 2); + y := DecodeInt(FBuffer, j); + Inc(j, 2); + z := DecodeInt(FBuffer, j); + Inc(j, 2); + R := IntToStr(x); // Priority + R := R + ',' + IntToStr(y); // Weight + R := R + ',' + IntToStr(z); // Port + R := R + ',' + DecodeLabels(j); // Server DNS Name + end; + end; + if R <> '' then + Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); + if QType = RType then + Result := R; +end; + +function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; +var + l: integer; +begin + Result := ''; + l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); + if l > 0 then + Result := WorkSock.RecvBufferStr(l, FTimeout); +end; + +function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; + QType: Integer):boolean; +var + n, i: Integer; + flag, qdcount, ancount, nscount, arcount: Integer; + s: AnsiString; +begin + Result := False; + Reply.Clear; + FAnswerInfo.Clear; + FNameserverInfo.Clear; + FAdditionalInfo.Clear; + FAuthoritative := False; + if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then + begin + Result := True; + flag := DecodeInt(Buf, 3); + FRCode := Flag and $000F; + FAuthoritative := (Flag and $0400) > 0; + FTruncated := (Flag and $0200) > 0; + if FRCode = 0 then + begin + qdcount := DecodeInt(Buf, 5); + ancount := DecodeInt(Buf, 7); + nscount := DecodeInt(Buf, 9); + arcount := DecodeInt(Buf, 11); + i := 13; //begin of body + if (qdcount > 0) and (Length(Buf) > i) then //skip questions + for n := 1 to qdcount do + begin + while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do + Inc(i); + Inc(i, 5); + end; + if (ancount > 0) and (Length(Buf) > i) then // decode reply + for n := 1 to ancount do + begin + s := DecodeResource(i, FAnswerInfo, QType); + if s <> '' then + Reply.Add(s); + end; + if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info + for n := 1 to nscount do + DecodeResource(i, FNameserverInfo, QType); + if (arcount > 0) and (Length(Buf) > i) then // decode additional info + for n := 1 to arcount do + DecodeResource(i, FAdditionalInfo, QType); + end; + end; +end; + +function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; + const Reply: TStrings): Boolean; +var + WorkSock: TBlockSocket; + t: TStringList; + b: boolean; +begin + Result := False; + if IsIP(Name) then + Name := ReverseIP(Name) + '.in-addr.arpa'; + if IsIP6(Name) then + Name := ReverseIP6(Name) + '.ip6.arpa'; + FBuffer := CodeHeader + CodeQuery(Name, QType); + if FUseTCP then + WorkSock := FTCPSock + else + WorkSock := FSock; + WorkSock.Bind(FIPInterface, cAnyPort); + WorkSock.Connect(FTargetHost, FTargetPort); + if FUseTCP then + FBuffer := Codeint(length(FBuffer)) + FBuffer; + WorkSock.SendString(FBuffer); + if FUseTCP then + FBuffer := RecvTCPResponse(WorkSock) + else + FBuffer := WorkSock.RecvPacket(FTimeout); + if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer + begin + t := TStringList.Create; + try + repeat + b := DecodeResponse(FBuffer, Reply, QType); + if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer + b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); + if b then + begin + t.AddStrings(AnswerInfo); + FBuffer := RecvTCPResponse(WorkSock); + if FBuffer = '' then + Break; + if WorkSock.LastError <> 0 then + Break; + end; + until not b; + Reply.Assign(t); + Result := True; + finally + t.free; + end; + end + else //normal query + if WorkSock.LastError = 0 then + Result := DecodeResponse(FBuffer, Reply, QType); +end; + +{==============================================================================} + +function GetMailServers(const DNSHost, Domain: AnsiString; + const Servers: TStrings): Boolean; +var + DNS: TDNSSend; + t: TStringList; + n, m, x: Integer; +begin + Result := False; + Servers.Clear; + t := TStringList.Create; + DNS := TDNSSend.Create; + try + DNS.TargetHost := DNSHost; + if DNS.DNSQuery(Domain, QType_MX, t) then + begin + { normalize preference number to 5 digits } + for n := 0 to t.Count - 1 do + begin + x := Pos(',', t[n]); + if x > 0 then + for m := 1 to 6 - x do + t[n] := '0' + t[n]; + end; + { sort server list } + t.Sorted := True; + { result is sorted list without preference numbers } + for n := 0 to t.Count - 1 do + begin + x := Pos(',', t[n]); + Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x)); + end; + Result := True; + end; + finally + DNS.Free; + t.Free; + end; +end; + +end. diff --git a/ftpsend.pas b/ftpsend.pas new file mode 100644 index 0000000..20cc9b4 --- /dev/null +++ b/ftpsend.pas @@ -0,0 +1,1964 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.000 | +|==============================================================================| +| Content: FTP client | +|==============================================================================| +| Copyright (c)1999-2011, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Petr Esner | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(FTP client protocol) + +Used RFC: RFC-959, RFC-2228, RFC-2428 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published + // and it requires RTTI to be generated $M+ +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ftpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synaip, synsock; + +const + cFtpProtocol = '21'; + cFtpDataProtocol = '20'; + + {:Terminating value for TLogonActions} + FTP_OK = 255; + {:Terminating value for TLogonActions} + FTP_ERR = 254; + +type + {:Array for holding definition of logon sequence.} + TLogonActions = array [0..17] of byte; + + {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object. + Value is FTP command or reply to this comand. (if it is reply, Response + is @True).} + TFTPStatus = procedure(Sender: TObject; Response: Boolean; + const Value: string) of object; + + {: @abstract(Object for holding file information) parsed from directory + listing of FTP server.} + TFTPListRec = class(TObject) + private + FFileName: String; + FDirectory: Boolean; + FReadable: Boolean; + FFileSize: int64; + FFileTime: TDateTime; + FOriginalLine: string; + FMask: string; + FPermission: String; + public + {: You can assign another TFTPListRec to this object.} + procedure Assign(Value: TFTPListRec); virtual; + {:name of file} + property FileName: string read FFileName write FFileName; + {:if name is subdirectory not file.} + property Directory: Boolean read FDirectory write FDirectory; + {:if you have rights to read} + property Readable: Boolean read FReadable write FReadable; + {:size of file in bytes} + property FileSize: int64 read FFileSize write FFileSize; + {:date and time of file. Local server timezone is used. Any timezone + conversions was not done!} + property FileTime: TDateTime read FFileTime write FFileTime; + {:original unparsed line} + property OriginalLine: string read FOriginalLine write FOriginalLine; + {:mask what was used for parsing} + property Mask: string read FMask write FMask; + {:permission string (depending on used mask!)} + property Permission: string read FPermission write FPermission; + end; + + {:@abstract(This is TList of TFTPListRec objects.) + This object is used for holding lististing of all files information in listed + directory on FTP server.} + TFTPList = class(TObject) + protected + FList: TList; + FLines: TStringList; + FMasks: TStringList; + FUnparsedLines: TStringList; + Monthnames: string; + BlockSize: string; + DirFlagValue: string; + FileName: string; + VMSFileName: string; + Day: string; + Month: string; + ThreeMonth: string; + YearTime: string; + Year: string; + Hours: string; + HoursModif: string; + Minutes: string; + Seconds: string; + Size: string; + Permissions: string; + DirFlag: string; + function GetListItem(Index: integer): TFTPListRec; virtual; + function ParseEPLF(Value: string): Boolean; virtual; + procedure ClearStore; virtual; + function ParseByMask(Value, NextValue, Mask: string): Integer; virtual; + function CheckValues: Boolean; virtual; + procedure FillRecord(const Value: TFTPListRec); virtual; + public + {:Constructor. You not need create this object, it is created by TFTPSend + class as their property.} + constructor Create; + destructor Destroy; override; + + {:Clear list.} + procedure Clear; virtual; + + {:count of holded @link(TFTPListRec) objects} + function Count: integer; virtual; + + {:Assigns one list to another} + procedure Assign(Value: TFTPList); virtual; + + {:try to parse raw directory listing in @link(lines) to list of + @link(TFTPListRec).} + procedure ParseLines; virtual; + + {:By this property you have access to list of @link(TFTPListRec). + This is for compatibility only. Please, use @link(Items) instead.} + property List: TList read FList; + + {:By this property you have access to list of @link(TFTPListRec).} + property Items[Index: Integer]: TFTPListRec read GetListItem; default; + + {:Set of lines with RAW directory listing for @link(parseLines)} + property Lines: TStringList read FLines; + + {:Set of masks for directory listing parser. It is predefined by default, + however you can modify it as you need. (for example, you can add your own + definition mask.) Mask is same as mask used in TotalCommander.} + property Masks: TStringList read FMasks; + + {:After @link(ParseLines) it holding lines what was not sucessfully parsed.} + property UnparsedLines: TStringList read FUnparsedLines; + end; + + {:@abstract(Implementation of FTP protocol.) + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! (Username and Password have default values + for "anonymous" FTP login) + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TFTPSend = class(TSynaClient) + protected + FOnStatus: TFTPStatus; + FSock: TTCPBlockSocket; + FDSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FAccount: string; + FFWHost: string; + FFWPort: string; + FFWUsername: string; + FFWPassword: string; + FFWMode: integer; + FDataStream: TMemoryStream; + FDataIP: string; + FDataPort: string; + FDirectFile: Boolean; + FDirectFileName: string; + FCanResume: Boolean; + FPassiveMode: Boolean; + FForceDefaultPort: Boolean; + FForceOldPort: Boolean; + FFtpList: TFTPList; + FBinaryMode: Boolean; + FAutoTLS: Boolean; + FIsTLS: Boolean; + FIsDataTLS: Boolean; + FTLSonData: Boolean; + FFullSSL: Boolean; + function Auth(Mode: integer): Boolean; virtual; + function Connect: Boolean; virtual; + function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual; + function DataSocket: Boolean; virtual; + function AcceptDataSocket: Boolean; virtual; + procedure DoStatus(Response: Boolean; const Value: string); virtual; + public + {:Custom definition of login sequence. You can use this when you set + @link(FWMode) to value -1.} + CustomLogon: TLogonActions; + + constructor Create; + destructor Destroy; override; + + {:Waits and read FTP server response. You need this only in special cases!} + function ReadResult: Integer; virtual; + + {:Parse remote side information of data channel from value string (returned + by PASV command). This function you need only in special cases!} + procedure ParseRemote(Value: string); virtual; + + {:Parse remote side information of data channel from value string (returned + by EPSV command). This function you need only in special cases!} + procedure ParseRemoteEPSV(Value: string); virtual; + + {:Send Value as FTP command to FTP server. Returned result code is result of + this function. + This command is good for sending site specific command, or non-standard + commands.} + function FTPCommand(const Value: string): integer; virtual; + + {:Connect and logon to FTP server. If you specify any FireWall, connect to + firewall and throw them connect to FTP server. Login sequence depending on + @link(FWMode).} + function Login: Boolean; virtual; + + {:Logoff and disconnect from FTP server.} + function Logout: Boolean; virtual; + + {:Break current transmission of data. (You can call this method from + Sock.OnStatus event, or from another thread.)} + procedure Abort; virtual; + + {:Break current transmission of data. It is same as Abort, but it send abort + telnet commands prior ABOR FTP command. Some servers need it. (You can call + this method from Sock.OnStatus event, or from another thread.)} + procedure TelnetAbort; virtual; + + {:Download directory listing of Directory on FTP server. If Directory is + empty string, download listing of current working directory. + If NameList is @true, download only names of files in directory. + (internally use NLST command instead LIST command) + If NameList is @false, returned list is also parsed to @link(FTPList) + property.} + function List(Directory: string; NameList: Boolean): Boolean; virtual; + + {:Read data from FileName on FTP server. If Restore is @true and server + supports resume dowloads, download is resumed. (received is only rest + of file)} + function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FileName on FTP server. If Restore is @true and server + supports resume upload, upload is resumed. (send only rest of file) + In this case if remote file is same length as local file, nothing will be + done. If remote file is larger then local, resume is disabled and file is + transfered from begin!} + function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FTP server and assing unique name for this file.} + function StoreUniqueFile: Boolean; virtual; + + {:Append data to FileName on FTP server.} + function AppendFile(const FileName: string): Boolean; virtual; + + {:Rename on FTP server file with OldName to NewName.} + function RenameFile(const OldName, NewName: string): Boolean; virtual; + + {:Delete file FileName on FTP server.} + function DeleteFile(const FileName: string): Boolean; virtual; + + {:Return size of Filename file on FTP server. If command failed (i.e. not + implemented), return -1.} + function FileSize(const FileName: string): int64; virtual; + + {:Send NOOP command to FTP server for preserve of disconnect by inactivity + timeout.} + function NoOp: Boolean; virtual; + + {:Change currect working directory to Directory on FTP server.} + function ChangeWorkingDir(const Directory: string): Boolean; virtual; + + {:walk to upper directory on FTP server.} + function ChangeToParentDir: Boolean; virtual; + + {:walk to root directory on FTP server. (May not work with all servers properly!)} + function ChangeToRootDir: Boolean; virtual; + + {:Delete Directory on FTP server.} + function DeleteDir(const Directory: string): Boolean; virtual; + + {:Create Directory on FTP server.} + function CreateDir(const Directory: string): Boolean; virtual; + + {:Return current working directory on FTP server.} + function GetCurrentDir: String; virtual; + + {:Establish data channel to FTP server and retrieve data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command!} + function DataRead(const DestStream: TStream): Boolean; virtual; + + {:Establish data channel to FTP server and send data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command.} + function DataWrite(const SourceStream: TStream): Boolean; virtual; + published + {:After FTP command contains result number of this operation.} + property ResultCode: Integer read FResultCode; + + {:After FTP command contains main line of result.} + property ResultString: string read FResultString; + + {:After any FTP command it contains all lines of FTP server reply.} + property FullResult: TStringList read FFullResult; + + {:Account information used in some cases inside login sequence.} + property Account: string read FAccount Write FAccount; + + {:Address of firewall. If empty string (default), firewall not used.} + property FWHost: string read FFWHost Write FFWHost; + + {:port of firewall. standard value is same port as ftp server used. (21)} + property FWPort: string read FFWPort Write FFWPort; + + {:Username for login to firewall. (if needed)} + property FWUsername: string read FFWUsername Write FFWUsername; + + {:password for login to firewall. (if needed)} + property FWPassword: string read FFWPassword Write FFWPassword; + + {:Type of Firewall. Used only if you set some firewall address. Supported + predefined firewall login sequences are described by comments in source + file where you can see pseudocode decribing each sequence.} + property FWMode: integer read FFWMode Write FFWMode; + + {:Socket object used for TCP/IP operation on control channel. Good for + seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:Socket object used for TCP/IP operation on data channel. Good for seting + OnStatus hook, etc.} + property DSock: TTCPBlockSocket read FDSock; + + {:If you not use @link(DirectFile) mode, all data transfers is made to or + from this stream.} + property DataStream: TMemoryStream read FDataStream; + + {:After data connection is established, contains remote side IP of this + connection.} + property DataIP: string read FDataIP; + + {:After data connection is established, contains remote side port of this + connection.} + property DataPort: string read FDataPort; + + {:Mode of data handling by data connection. If @False, all data operations + are made to or from @link(DataStream) TMemoryStream. + If @true, data operations is made directly to file in your disk. (filename + is specified by @link(DirectFileName) property.) Dafault is @False!} + property DirectFile: Boolean read FDirectFile Write FDirectFile; + + {:Filename for direct disk data operations.} + property DirectFileName: string read FDirectFileName Write FDirectFileName; + + {:Indicate after @link(Login) if remote server support resume downloads and + uploads.} + property CanResume: Boolean read FCanResume; + + {:If true (default value), all transfers is made by passive method. + It is safer method for various firewalls.} + property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; + + {:Force to listen for dataconnection on standard port (20). Default is @false, + dataconnections will be made to any non-standard port reported by PORT FTP + command. This setting is not used, if you use passive mode.} + property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; + + {:When is @true, then is disabled EPSV and EPRT support. However without this + commands you cannot use IPv6! (Disabling of this commands is needed only + when you are behind some crap firewall/NAT.} + property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort; + + {:You may set this hook for monitoring FTP commands and replies.} + property OnStatus: TFTPStatus read FOnStatus write FOnStatus; + + {:After LIST command is here parsed list of files in given directory.} + property FtpList: TFTPList read FFtpList; + + {:if @true (default), then data transfers is in binary mode. If this is set + to @false, then ASCII mode is used.} + property BinaryMode: Boolean read FBinaryMode Write FBinaryMode; + + {:if is true, then if server support upgrade to SSL/TLS mode, then use them.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:if server listen on SSL/TLS port, then you set this to true.} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Signalise, if control channel is in SSL/TLS mode.} + property IsTLS: Boolean read FIsTLS; + + {:Signalise, if data transfers is in SSL/TLS mode.} + property IsDataTLS: Boolean read FIsDataTLS; + + {:If @true (default), then try to use SSL/TLS on data transfers too. + If @false, then SSL/TLS is used only for control connection.} + property TLSonData: Boolean read FTLSonData write FTLSonData; + end; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Dowload specified file from FTP server to LocalFile.} +function FtpGetFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Upload specified LocalFile to FTP server.} +function FtpPutFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Initiate transfer of file between two FTP servers.} +function FtpInterServerTransfer( + const FromIP, FromPort, FromFile, FromUser, FromPass: string; + const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; + +implementation + +constructor TFTPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FDataStream := TMemoryStream.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := True; + FDSock := TTCPBlockSocket.Create; + FDSock.Owner := self; + FFtpList := TFTPList.Create; + FTimeout := 300000; + FTargetPort := cFtpProtocol; + FUsername := 'anonymous'; + FPassword := 'anonymous@' + FSock.LocalName; + FDirectFile := False; + FPassiveMode := True; + FForceDefaultPort := False; + FForceOldPort := false; + FAccount := ''; + FFWHost := ''; + FFWPort := cFtpProtocol; + FFWUsername := ''; + FFWPassword := ''; + FFWMode := 0; + FBinaryMode := True; + FAutoTLS := False; + FFullSSL := False; + FIsTLS := False; + FIsDataTLS := False; + FTLSonData := True; +end; + +destructor TFTPSend.Destroy; +begin + FDSock.Free; + FSock.Free; + FFTPList.Free; + FDataStream.Free; + FFullResult.Free; + inherited Destroy; +end; + +procedure TFTPSend.DoStatus(Response: Boolean; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Response, Value); +end; + +function TFTPSend.ReadResult: Integer; +var + s, c: string; +begin + FFullResult.Clear; + c := ''; + repeat + s := FSock.RecvString(FTimeout); + if c = '' then + if length(s) > 3 then + if s[4] in [' ', '-'] then + c :=Copy(s, 1, 3); + FResultString := s; + FFullResult.Add(s); + DoStatus(True, s); + if FSock.LastError <> 0 then + Break; + until (c <> '') and (Pos(c + ' ', s) = 1); + Result := StrToIntDef(c, 0); + FResultCode := Result; +end; + +function TFTPSend.FTPCommand(const Value: string): integer; +begin + FSock.Purge; + FSock.SendString(Value + CRLF); + DoStatus(False, Value); + Result := ReadResult; +end; + +// based on idea by Petr Esner +function TFTPSend.Auth(Mode: integer): Boolean; +const + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! + Action0: TLogonActions = + (0, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER then + // if not PASS then ERROR! + //if SITE then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! + Action1: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 5, FTP_ERR, 9, + 0, FTP_OK, 12, + 1, FTP_OK, 15, + 2, FTP_OK, FTP_ERR); + + //if not USER then + // if not PASS then ERROR! + //if USER '@' then OK! + //if not PASS then + // if not ACCT then ERROR! + //OK! + Action2: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 6, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //if not USER then + // if not PASS then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! + Action3: TLogonActions = + (3, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //OPEN + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! + Action4: TLogonActions = + (7, 3, 3, + 0, FTP_OK, 6, + 1, FTP_OK, 9, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0); + + //if USER '@' then OK! + //if not PASS then + // if not ACCT then ERROR! + //OK! + Action5: TLogonActions = + (6, FTP_OK, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER @ then + // if not PASS then ERROR! + //if not USER then + // if not PASS then + // if not ACCT then ERROR! + //OK! + Action6: TLogonActions = + (8, 6, 3, + 4, 6, FTP_ERR, + 0, FTP_OK, 9, + 1, FTP_OK, 12, + 2, FTP_OK, FTP_ERR, + 0, 0, 0); + + //if USER @ then ERROR! + //if not PASS then + // if not ACCT then ERROR! + //OK! + Action7: TLogonActions = + (9, FTP_ERR, 3, + 1, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); + + //if not USER @@ then + // if not PASS @ then + // if not ACCT then ERROR! + //OK! + Action8: TLogonActions = + (10, FTP_OK, 3, + 11, FTP_OK, 6, + 2, FTP_OK, FTP_ERR, + 0, 0, 0, 0, 0, 0, 0, 0, 0); +var + FTPServer: string; + LogonActions: TLogonActions; + i: integer; + s: string; + x: integer; +begin + Result := False; + if FFWHost = '' then + Mode := 0; + if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then + FTPServer := FTargetHost + else + FTPServer := FTargetHost + ':' + FTargetPort; + case Mode of + -1: + LogonActions := CustomLogon; + 1: + LogonActions := Action1; + 2: + LogonActions := Action2; + 3: + LogonActions := Action3; + 4: + LogonActions := Action4; + 5: + LogonActions := Action5; + 6: + LogonActions := Action6; + 7: + LogonActions := Action7; + 8: + LogonActions := Action8; + else + LogonActions := Action0; + end; + i := 0; + repeat + case LogonActions[i] of + 0: s := 'USER ' + FUserName; + 1: s := 'PASS ' + FPassword; + 2: s := 'ACCT ' + FAccount; + 3: s := 'USER ' + FFWUserName; + 4: s := 'PASS ' + FFWPassword; + 5: s := 'SITE ' + FTPServer; + 6: s := 'USER ' + FUserName + '@' + FTPServer; + 7: s := 'OPEN ' + FTPServer; + 8: s := 'USER ' + FFWUserName + '@' + FTPServer; + 9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName; + 10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer; + 11: s := 'PASS ' + FPassword + '@' + FFWPassword; + end; + x := FTPCommand(s); + x := x div 100; + if (x <> 2) and (x <> 3) then + Exit; + i := LogonActions[i + x - 1]; + case i of + FTP_ERR: + Exit; + FTP_OK: + begin + Result := True; + Exit; + end; + end; + until False; +end; + + +function TFTPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + if FFWHost = '' then + FSock.Connect(FTargetHost, FTargetPort) + else + FSock.Connect(FFWHost, FFWPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TFTPSend.Login: Boolean; +var + x: integer; +begin + Result := False; + FCanResume := False; + if not Connect then + Exit; + FIsTLS := FFullSSL; + FIsDataTLS := False; + repeat + x := ReadResult div 100; + until x <> 1; + if x <> 2 then + Exit; + if FAutoTLS and not(FIsTLS) then + if (FTPCommand('AUTH TLS') div 100) = 2 then + begin + FSock.SSLDoConnect; + FIsTLS := FSock.LastError = 0; + if not FIsTLS then + begin + Result := False; + Exit; + end; + end; + if not Auth(FFWMode) then + Exit; + if FIsTLS then + begin + FTPCommand('PBSZ 0'); + if FTLSonData then + FIsDataTLS := (FTPCommand('PROT P') div 100) = 2; + if not FIsDataTLS then + FTPCommand('PROT C'); + end; + FTPCommand('TYPE I'); + FTPCommand('STRU F'); + FTPCommand('MODE S'); + if FTPCommand('REST 0') = 350 then + if FTPCommand('REST 1') = 350 then + begin + FTPCommand('REST 0'); + FCanResume := True; + end; + Result := True; +end; + +function TFTPSend.Logout: Boolean; +begin + Result := (FTPCommand('QUIT') div 100) = 2; + FSock.CloseSocket; +end; + +procedure TFTPSend.ParseRemote(Value: string); +var + n: integer; + nb, ne: integer; + s: string; + x: integer; +begin + Value := trim(Value); + nb := Pos('(',Value); + ne := Pos(')',Value); + if (nb = 0) or (ne = 0) then + begin + nb:=RPos(' ',Value); + s:=Copy(Value, nb + 1, Length(Value) - nb); + end + else + begin + s:=Copy(Value,nb+1,ne-nb-1); + end; + for n := 1 to 4 do + if n = 1 then + FDataIP := Fetch(s, ',') + else + FDataIP := FDataIP + '.' + Fetch(s, ','); + x := StrToIntDef(Fetch(s, ','), 0) * 256; + x := x + StrToIntDef(Fetch(s, ','), 0); + FDataPort := IntToStr(x); +end; + +procedure TFTPSend.ParseRemoteEPSV(Value: string); +var + n: integer; + s, v: string; +begin + s := SeparateRight(Value, '('); + s := Trim(SeparateLeft(s, ')')); + Delete(s, Length(s), 1); + v := ''; + for n := Length(s) downto 1 do + if s[n] in ['0'..'9'] then + v := s[n] + v + else + Break; + FDataPort := v; + FDataIP := FTargetHost; +end; + +function TFTPSend.DataSocket: boolean; +var + s: string; +begin + Result := False; + if FIsDataTLS then + FPassiveMode := True; + if FPassiveMode then + begin + if FSock.IP6used then + s := '2' + else + s := '1'; + if FSock.IP6used and not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then + begin + ParseRemoteEPSV(FResultString); + end + else + if FSock.IP6used then + Exit + else + begin + if (FTPCommand('PASV') div 100) <> 2 then + Exit; + ParseRemote(FResultString); + end; + FDSock.CloseSocket; + FDSock.Bind(FIPInterface, cAnyPort); + FDSock.Connect(FDataIP, FDataPort); + Result := FDSock.LastError = 0; + end + else + begin + FDSock.CloseSocket; + if FForceDefaultPort then + s := cFtpDataProtocol + else + s := '0'; + //data conection from same interface as command connection + FDSock.Bind(FSock.GetLocalSinIP, s); + if FDSock.LastError <> 0 then + Exit; + FDSock.SetLinger(True, 10000); + FDSock.Listen; + FDSock.GetSins; + FDataIP := FDSock.GetLocalSinIP; + FDataIP := FDSock.ResolveName(FDataIP); + FDataPort := IntToStr(FDSock.GetLocalSinPort); + if FSock.IP6used and (not FForceOldPort) then + begin + if IsIp6(FDataIP) then + s := '2' + else + s := '1'; + s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|'; + Result := (FTPCommand(s) div 100) = 2; + end; + if not Result and IsIP(FDataIP) then + begin + s := ReplaceString(FDataIP, '.', ','); + s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) + + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); + Result := (FTPCommand(s) div 100) = 2; + end; + end; +end; + +function TFTPSend.AcceptDataSocket: Boolean; +var + x: TSocket; +begin + if FPassiveMode then + Result := True + else + begin + Result := False; + if FDSock.CanRead(FTimeout) then + begin + x := FDSock.Accept; + if not FDSock.UsingSocks then + FDSock.CloseSocket; + FDSock.Socket := x; + Result := True; + end; + end; + if Result and FIsDataTLS then + begin + FDSock.SSL.Assign(FSock.SSL); + FDSock.SSLDoConnect; + Result := FDSock.LastError = 0; + end; +end; + +function TFTPSend.DataRead(const DestStream: TStream): Boolean; +var + x: integer; +begin + Result := False; + try + if not AcceptDataSocket then + Exit; + FDSock.RecvStreamRaw(DestStream, FTimeout); + FDSock.CloseSocket; + x := ReadResult; + Result := (x div 100) = 2; + finally + FDSock.CloseSocket; + end; +end; + +function TFTPSend.DataWrite(const SourceStream: TStream): Boolean; +var + x: integer; + b: Boolean; +begin + Result := False; + try + if not AcceptDataSocket then + Exit; + FDSock.SendStreamRaw(SourceStream); + b := FDSock.LastError = 0; + FDSock.CloseSocket; + x := ReadResult; + Result := b and ((x div 100) = 2); + finally + FDSock.CloseSocket; + end; +end; + +function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; +var + x: integer; +begin + Result := False; + FDataStream.Clear; + FFTPList.Clear; + if Directory <> '' then + Directory := ' ' + Directory; + FTPCommand('TYPE A'); + if not DataSocket then + Exit; + if NameList then + x := FTPCommand('NLST' + Directory) + else + x := FTPCommand('LIST' + Directory); + if (x div 100) <> 1 then + Exit; + Result := DataRead(FDataStream); + if (not NameList) and Result then + begin + FDataStream.Position := 0; + FFTPList.Lines.LoadFromStream(FDataStream); + FFTPList.ParseLines; + end; + FDataStream.Position := 0; +end; + +function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean; +var + RetrStream: TStream; +begin + Result := False; + if FileName = '' then + Exit; + if not DataSocket then + Exit; + Restore := Restore and FCanResume; + if FDirectFile then + if Restore and FileExists(FDirectFileName) then + RetrStream := TFileStream.Create(FDirectFileName, + fmOpenReadWrite or fmShareExclusive) + else + RetrStream := TFileStream.Create(FDirectFileName, + fmCreate or fmShareDenyWrite) + else + RetrStream := FDataStream; + try + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); + if Restore then + begin + RetrStream.Position := RetrStream.Size; + if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then + Exit; + end + else + if RetrStream is TMemoryStream then + TMemoryStream(RetrStream).Clear; + if (FTPCommand('RETR ' + FileName) div 100) <> 1 then + Exit; + Result := DataRead(RetrStream); + if not FDirectFile then + RetrStream.Position := 0; + finally + if FDirectFile then + RetrStream.Free; + end; +end; + +function TFTPSend.InternalStor(const Command: string; RestoreAt: int64): Boolean; +var + SendStream: TStream; + StorSize: int64; +begin + Result := False; + if FDirectFile then + if not FileExists(FDirectFileName) then + Exit + else + SendStream := TFileStream.Create(FDirectFileName, + fmOpenRead or fmShareDenyWrite) + else + SendStream := FDataStream; + try + if not DataSocket then + Exit; + if FBinaryMode then + FTPCommand('TYPE I') + else + FTPCommand('TYPE A'); + StorSize := SendStream.Size; + if not FCanResume then + RestoreAt := 0; + if (StorSize > 0) and (RestoreAt = StorSize) then + begin + Result := True; + Exit; + end; + if RestoreAt > StorSize then + RestoreAt := 0; + FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); + if FCanResume then + if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then + Exit; + SendStream.Position := RestoreAt; + if (FTPCommand(Command) div 100) <> 1 then + Exit; + Result := DataWrite(SendStream); + finally + if FDirectFile then + SendStream.Free; + end; +end; + +function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean; +var + RestoreAt: int64; +begin + Result := False; + if FileName = '' then + Exit; + RestoreAt := 0; + Restore := Restore and FCanResume; + if Restore then + begin + RestoreAt := Self.FileSize(FileName); + if RestoreAt < 0 then + RestoreAt := 0; + end; + Result := InternalStor('STOR ' + FileName, RestoreAt); +end; + +function TFTPSend.StoreUniqueFile: Boolean; +begin + Result := InternalStor('STOU', 0); +end; + +function TFTPSend.AppendFile(const FileName: string): Boolean; +begin + Result := False; + if FileName = '' then + Exit; + Result := InternalStor('APPE ' + FileName, 0); +end; + +function TFTPSend.NoOp: Boolean; +begin + Result := (FTPCommand('NOOP') div 100) = 2; +end; + +function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; +begin + Result := False; + if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then + Exit; + Result := (FTPCommand('RNTO ' + NewName) div 100) = 2; +end; + +function TFTPSend.DeleteFile(const FileName: string): Boolean; +begin + Result := (FTPCommand('DELE ' + FileName) div 100) = 2; +end; + +function TFTPSend.FileSize(const FileName: string): int64; +var + s: string; +begin + Result := -1; + if (FTPCommand('SIZE ' + FileName) div 100) = 2 then + begin + s := Trim(SeparateRight(ResultString, ' ')); + s := Trim(SeparateLeft(s, ' ')); + {$IFDEF VER100} + Result := StrToIntDef(s, -1); + {$ELSE} + Result := StrToInt64Def(s, -1); + {$ENDIF} + end; +end; + +function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('CWD ' + Directory) div 100) = 2; +end; + +function TFTPSend.ChangeToParentDir: Boolean; +begin + Result := (FTPCommand('CDUP') div 100) = 2; +end; + +function TFTPSend.ChangeToRootDir: Boolean; +begin + Result := ChangeWorkingDir('/'); +end; + +function TFTPSend.DeleteDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('RMD ' + Directory) div 100) = 2; +end; + +function TFTPSend.CreateDir(const Directory: string): Boolean; +begin + Result := (FTPCommand('MKD ' + Directory) div 100) = 2; +end; + +function TFTPSend.GetCurrentDir: String; +begin + Result := ''; + if (FTPCommand('PWD') div 100) = 2 then + begin + Result := SeparateRight(FResultString, '"'); + Result := Trim(Separateleft(Result, '"')); + end; +end; + +procedure TFTPSend.Abort; +begin + FSock.SendString('ABOR' + CRLF); + FDSock.StopFlag := True; +end; + +procedure TFTPSend.TelnetAbort; +begin + FSock.SendString(#$FF + #$F4 + #$FF + #$F2); + Abort; +end; + +{==============================================================================} + +procedure TFTPListRec.Assign(Value: TFTPListRec); +begin + FFileName := Value.FileName; + FDirectory := Value.Directory; + FReadable := Value.Readable; + FFileSize := Value.FileSize; + FFileTime := Value.FileTime; + FOriginalLine := Value.OriginalLine; + FMask := Value.Mask; +end; + +constructor TFTPList.Create; +begin + inherited Create; + FList := TList.Create; + FLines := TStringList.Create; + FMasks := TStringList.Create; + FUnparsedLines := TStringList.Create; + //various UNIX + FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format + FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*'); + //MacOS + FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*'); + FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*'); + //Novell + FMasks.add('d $!S*$TTT$DD$UUUUU$n*'); + //Windows + FMasks.add('MM DD YY hh mmH !S* n*'); + FMasks.add('MM DD YY hh mmH $ d!n*'); + FMasks.add('MM DD YYYY hh mmH !S* n*'); + FMasks.add('MM DD YYYY hh mmH $ d!n*'); + FMasks.add('DD MM YYYY hh mmH !S* n*'); + FMasks.add('DD MM YYYY hh mmH $ d!n*'); + //VMS + FMasks.add('v*$ DD TTT YYYY hh mm'); + FMasks.add('v*$!DD TTT YYYY hh mm'); + FMasks.add('n*$ YYYY MM DD hh mm$S*'); + //AS400 + FMasks.add('!S*$MM DD YY hh mm ss !n*'); + FMasks.add('!S*$DD MM YY hh mm ss !n*'); + FMasks.add('n*!S*$MM DD YY hh mm ss d'); + FMasks.add('n*!S*$DD MM YY hh mm ss d'); + //VxWorks + FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d'); + FMasks.add('$S* TTT DD YYYY hh mm ss $n*'); + //Distinct + FMasks.add('d $S*$TTT DD YYYY hh mm$n*'); + FMasks.add('d $S*$TTT DD$hh mm$n*'); + //PC-NFSD + FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH'); + //VOS + FMasks.add('- SSSSS YY MM DD hh mm ss n*'); + FMasks.add('- d= SSSSS YY MM DD hh mm ss n*'); + //Unissys ClearPath + FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm'); + FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm'); + //IBM + FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*'); + //OS9 + FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*'); + //tandem + FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss'); + //MVS + FMasks.add('- YYYY MM DD SSSSS d=O n*'); + //BullGCOS8 + FMasks.add(' $S* MM DD YY hh mm ss !n*'); + FMasks.add('d $S* MM DD YY !n*'); + //BullGCOS7 + FMasks.add(' TTT DD YYYY n*'); + FMasks.add(' d n*'); +end; + +destructor TFTPList.Destroy; +begin + Clear; + FList.Free; + FLines.Free; + FMasks.Free; + FUnparsedLines.Free; + inherited Destroy; +end; + +procedure TFTPList.Clear; +var + n:integer; +begin + for n := 0 to FList.Count - 1 do + if Assigned(FList[n]) then + TFTPListRec(FList[n]).Free; + FList.Clear; + FLines.Clear; + FUnparsedLines.Clear; +end; + +function TFTPList.Count: integer; +begin + Result := FList.Count; +end; + +function TFTPList.GetListItem(Index: integer): TFTPListRec; +begin + Result := nil; + if Index < Count then + Result := TFTPListRec(FList[Index]); +end; + +procedure TFTPList.Assign(Value: TFTPList); +var + flr: TFTPListRec; + n: integer; +begin + Clear; + for n := 0 to Value.Count - 1 do + begin + flr := TFTPListRec.Create; + flr.Assign(Value[n]); + Flist.Add(flr); + end; + Lines.Assign(Value.Lines); + Masks.Assign(Value.Masks); + UnparsedLines.Assign(Value.UnparsedLines); +end; + +procedure TFTPList.ClearStore; +begin + Monthnames := ''; + BlockSize := ''; + DirFlagValue := ''; + FileName := ''; + VMSFileName := ''; + Day := ''; + Month := ''; + ThreeMonth := ''; + YearTime := ''; + Year := ''; + Hours := ''; + HoursModif := ''; + Minutes := ''; + Seconds := ''; + Size := ''; + Permissions := ''; + DirFlag := ''; +end; + +function TFTPList.ParseByMask(Value, NextValue, Mask: string): Integer; +var + Ivalue, IMask: integer; + MaskC, LastMaskC: char; + c: char; + s: string; +begin + ClearStore; + Result := 0; + if Value = '' then + Exit; + if Mask = '' then + Exit; + Ivalue := 1; + IMask := 1; + Result := 1; + LastMaskC := ' '; + while Imask <= Length(mask) do + begin + if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then + begin + Result := 0; + Exit; + end; + MaskC := Mask[Imask]; + if Ivalue > Length(Value) then + Exit; + c := Value[Ivalue]; + case MaskC of + 'n': + FileName := FileName + c; + 'v': + VMSFileName := VMSFileName + c; + '.': + begin + if c in ['.', ' '] then + FileName := TrimSP(FileName) + '.' + else + begin + Result := 0; + Exit; + end; + end; + 'D': + Day := Day + c; + 'M': + Month := Month + c; + 'T': + ThreeMonth := ThreeMonth + c; + 'U': + YearTime := YearTime + c; + 'Y': + Year := Year + c; + 'h': + Hours := Hours + c; + 'H': + HoursModif := HoursModif + c; + 'm': + Minutes := Minutes + c; + 's': + Seconds := Seconds + c; + 'S': + Size := Size + c; + 'p': + Permissions := Permissions + c; + 'd': + DirFlag := DirFlag + c; + 'x': + if c <> ' ' then + begin + Result := 0; + Exit; + end; + '*': + begin + s := ''; + if LastMaskC in ['n', 'v'] then + begin + if Imask = Length(Mask) then + s := Copy(Value, IValue, Maxint) + else + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + if LastMaskC = 'n' then + FileName := FileName + s + else + VMSFileName := VMSFileName + s; + end + else + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in ['0'..'9']) then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + case LastMaskC of + 'S': + Size := Size + s; + end; + end; + Dec(IValue); + end; + '!': + begin + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + Inc(Ivalue); + end; + while IValue <= Length(Value) do + begin + if Value[Ivalue] <> ' ' then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '$': + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in [' ', #9]) then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '=': + begin + s := ''; + case LastmaskC of + 'S': + begin + while Imask <= Length(Mask) do + begin + if not(Mask[Imask] in ['0'..'9']) then + break; + s := s + Mask[Imask]; + Inc(Imask); + end; + Dec(Imask); + BlockSize := s; + end; + 'T': + begin + Monthnames := Copy(Mask, IMask, 12 * 3); + Inc(IMask, 12 * 3); + end; + 'd': + begin + Inc(Imask); + DirFlagValue := Mask[Imask]; + end; + end; + end; + '\': + begin + Value := NextValue; + IValue := 0; + Result := 2; + end; + end; + Inc(Ivalue); + Inc(Imask); + LastMaskC := MaskC; + end; +end; + +function TFTPList.CheckValues: Boolean; +var + x, n: integer; +begin + Result := false; + if FileName <> '' then + begin + if pos('?', VMSFilename) > 0 then + Exit; + if pos('*', VMSFilename) > 0 then + Exit; + end; + if VMSFileName <> '' then + if pos(';', VMSFilename) <= 0 then + Exit; + if (FileName = '') and (VMSFileName = '') then + Exit; + if Permissions <> '' then + begin + if length(Permissions) <> 10 then + Exit; + for n := 1 to 10 do + if not(Permissions[n] in + ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then + Exit; + end; + if Day <> '' then + begin + Day := TrimSP(Day); + x := StrToIntDef(day, -1); + if (x < 1) or (x > 31) then + Exit; + end; + if Month <> '' then + begin + Month := TrimSP(Month); + x := StrToIntDef(Month, -1); + if (x < 1) or (x > 12) then + Exit; + end; + if Hours <> '' then + begin + Hours := TrimSP(Hours); + x := StrToIntDef(Hours, -1); + if (x < 0) or (x > 24) then + Exit; + end; + if HoursModif <> '' then + begin + if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then + Exit; + end; + if Minutes <> '' then + begin + Minutes := TrimSP(Minutes); + x := StrToIntDef(Minutes, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Seconds <> '' then + begin + Seconds := TrimSP(Seconds); + x := StrToIntDef(Seconds, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Size <> '' then + begin + Size := TrimSP(Size); + for n := 1 to Length(Size) do + if not (Size[n] in ['0'..'9']) then + Exit; + end; + + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + begin + x := GetMonthNumber(ThreeMonth); + if (x = 0) then + Exit; + end; + if YearTime <> '' then + begin + YearTime := ReplaceString(YearTime, '-', ':'); + if pos(':', YearTime) > 0 then + begin + if (GetTimeFromstr(YearTime) = -1) then + Exit; + end + else + begin + YearTime := TrimSP(YearTime); + x := StrToIntDef(YearTime, -1); + if (x = -1) then + Exit; + if (x < 1900) or (x > 2100) then + Exit; + end; + end; + if Year <> '' then + begin + Year := TrimSP(Year); + x := StrToIntDef(Year, -1); + if (x = -1) then + Exit; + if Length(Year) = 4 then + begin + if not((x > 1900) and (x < 2100)) then + Exit; + end + else + if Length(Year) = 2 then + begin + if not((x >= 0) and (x <= 99)) then + Exit; + end + else + if Length(Year) = 3 then + begin + if not((x >= 100) and (x <= 110)) then + Exit; + end + else + Exit; + end; + Result := True; +end; + +procedure TFTPList.FillRecord(const Value: TFTPListRec); +var + s: string; + x: integer; + myear: Word; + mmonth: Word; + mday: Word; + mhours, mminutes, mseconds: word; + n: integer; +begin + s := DirFlagValue; + if s = '' then + s := 'D'; + s := Uppercase(s); + Value.Directory := s = Uppercase(DirFlag); + if FileName <> '' then + Value.FileName := SeparateLeft(Filename, ' -> '); + if VMSFileName <> '' then + begin + Value.FileName := VMSFilename; + Value.Directory := Pos('.DIR;',VMSFilename) > 0; + end; + Value.FileName := TrimSPRight(Value.FileName); + Value.Readable := not Value.Directory; + if BlockSize <> '' then + x := StrToIntDef(BlockSize, 1) + else + x := 1; + {$IFDEF VER100} + Value.FileSize := x * StrToIntDef(Size, 0); + {$ELSE} + Value.FileSize := x * StrToInt64Def(Size, 0); + {$ENDIF} + + DecodeDate(Date,myear,mmonth,mday); + mhours := 0; + mminutes := 0; + mseconds := 0; + + if Day <> '' then + mday := StrToIntDef(day, 1); + if Month <> '' then + mmonth := StrToIntDef(Month, 1); + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + mmonth := GetMonthNumber(ThreeMonth); + if Year <> '' then + begin + myear := StrToIntDef(Year, 0); + if (myear <= 99) and (myear > 50) then + myear := myear + 1900; + if myear <= 50 then + myear := myear + 2000; + end; + if YearTime <> '' then + begin + if pos(':', YearTime) > 0 then + begin + YearTime := TrimSP(YearTime); + mhours := StrToIntDef(Separateleft(YearTime, ':'), 0); + mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0); + if (Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, 0, 0)) > now then + Dec(mYear); + end + else + myear := StrToIntDef(YearTime, 0); + end; + if Minutes <> '' then + mminutes := StrToIntDef(Minutes, 0); + if Seconds <> '' then + mseconds := StrToIntDef(Seconds, 0); + if Hours <> '' then + begin + mHours := StrToIntDef(Hours, 0); + if HoursModif <> '' then + if Uppercase(HoursModif[1]) = 'P' then + if mHours <> 12 then + mHours := MHours + 12; + end; + Value.FileTime := Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, mseconds, 0); + if Permissions <> '' then + begin + Value.Permission := Permissions; + Value.Readable := Uppercase(permissions)[2] = 'R'; + if Uppercase(permissions)[1] = 'D' then + begin + Value.Directory := True; + Value.Readable := false; + end + else + if Uppercase(permissions)[1] = 'L' then + Value.Directory := True; + end; +end; + +function TFTPList.ParseEPLF(Value: string): Boolean; +var + s, os: string; + flr: TFTPListRec; +begin + Result := False; + if Value <> '' then + if Value[1] = '+' then + begin + os := Value; + Delete(Value, 1, 1); + flr := TFTPListRec.create; + flr.FileName := SeparateRight(Value, #9); + s := Fetch(Value, ','); + while s <> '' do + begin + if s[1] = #9 then + Break; + case s[1] of + '/': + flr.Directory := true; + 'r': + flr.Readable := true; + 's': + {$IFDEF VER100} + flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0); + {$ELSE} + flr.FileSize := StrToInt64Def(Copy(s, 2, Length(s) - 1), 0); + {$ENDIF} + 'm': + flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400) + + 25569; + end; + s := Fetch(Value, ','); + end; + if flr.FileName <> '' then + if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..'))) + or (flr.FileName = '') then + flr.free + else + begin + flr.OriginalLine := os; + flr.Mask := 'EPLF'; + Flist.Add(flr); + Result := True; + end; + end; +end; + +procedure TFTPList.ParseLines; +var + flr: TFTPListRec; + n, m: Integer; + S: string; + x: integer; + b: Boolean; +begin + n := 0; + while n < Lines.Count do + begin + if n = Lines.Count - 1 then + s := '' + else + s := Lines[n + 1]; + b := False; + x := 0; + if ParseEPLF(Lines[n]) then + begin + b := True; + x := 1; + end + else + for m := 0 to Masks.Count - 1 do + begin + x := ParseByMask(Lines[n], s, Masks[m]); + if x > 0 then + if CheckValues then + begin + flr := TFTPListRec.create; + FillRecord(flr); + flr.OriginalLine := Lines[n]; + flr.Mask := Masks[m]; + if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then + flr.free + else + Flist.Add(flr); + b := True; + Break; + end; + end; + if not b then + FUnparsedLines.Add(Lines[n]); + Inc(n); + if x > 1 then + Inc(n, x - 1); + end; +end; + +{==============================================================================} + +function FtpGetFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; +begin + Result := False; + with TFTPSend.Create do + try + if User <> '' then + begin + Username := User; + Password := Pass; + end; + TargetHost := IP; + TargetPort := Port; + if not Login then + Exit; + DirectFileName := LocalFile; + DirectFile:=True; + Result := RetrieveFile(FileName, False); + Logout; + finally + Free; + end; +end; + +function FtpPutFile(const IP, Port, FileName, LocalFile, + User, Pass: string): Boolean; +begin + Result := False; + with TFTPSend.Create do + try + if User <> '' then + begin + Username := User; + Password := Pass; + end; + TargetHost := IP; + TargetPort := Port; + if not Login then + Exit; + DirectFileName := LocalFile; + DirectFile:=True; + Result := StoreFile(FileName, False); + Logout; + finally + Free; + end; +end; + +function FtpInterServerTransfer( + const FromIP, FromPort, FromFile, FromUser, FromPass: string; + const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; +var + FromFTP, ToFTP: TFTPSend; + s: string; + x: integer; +begin + Result := False; + FromFTP := TFTPSend.Create; + toFTP := TFTPSend.Create; + try + if FromUser <> '' then + begin + FromFTP.Username := FromUser; + FromFTP.Password := FromPass; + end; + if ToUser <> '' then + begin + ToFTP.Username := ToUser; + ToFTP.Password := ToPass; + end; + FromFTP.TargetHost := FromIP; + FromFTP.TargetPort := FromPort; + ToFTP.TargetHost := ToIP; + ToFTP.TargetPort := ToPort; + if not FromFTP.Login then + Exit; + if not ToFTP.Login then + Exit; + if (FromFTP.FTPCommand('PASV') div 100) <> 2 then + Exit; + FromFTP.ParseRemote(FromFTP.ResultString); + s := ReplaceString(FromFTP.DataIP, '.', ','); + s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256) + + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256); + if (ToFTP.FTPCommand(s) div 100) <> 2 then + Exit; + x := ToFTP.FTPCommand('RETR ' + FromFile); + if (x div 100) <> 1 then + Exit; + x := FromFTP.FTPCommand('STOR ' + ToFile); + if (x div 100) <> 1 then + Exit; + FromFTP.Timeout := 21600000; + x := FromFTP.ReadResult; + if (x div 100) <> 2 then + Exit; + ToFTP.Timeout := 21600000; + x := ToFTP.ReadResult; + if (x div 100) <> 2 then + Exit; + Result := True; + finally + ToFTP.Free; + FromFTP.Free; + end; +end; + +end. diff --git a/ftptsend.pas b/ftptsend.pas new file mode 100644 index 0000000..1704c18 --- /dev/null +++ b/ftptsend.pas @@ -0,0 +1,418 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.001 | +|==============================================================================| +| Content: Trivial FTP (TFTP) client and server | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(TFTP client and server protocol) + +Used RFC: RFC-1350 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ftptsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cTFTPProtocol = '69'; + + cTFTP_RRQ = word(1); + cTFTP_WRQ = word(2); + cTFTP_DTA = word(3); + cTFTP_ACK = word(4); + cTFTP_ERR = word(5); + +type + {:@abstract(Implementation of TFTP client and server) + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TTFTPSend = class(TSynaClient) + private + FSock: TUDPBlockSocket; + FErrorCode: integer; + FErrorString: string; + FData: TMemoryStream; + FRequestIP: string; + FRequestPort: string; + function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; + function RecvPacket(Serial: word; var Value: string): Boolean; + public + constructor Create; + destructor Destroy; override; + + {:Upload @link(data) as file to TFTP server.} + function SendFile(const Filename: string): Boolean; + + {:Download file from TFTP server to @link(data).} + function RecvFile(const Filename: string): Boolean; + + {:Acts as TFTP server and wait for client request. When some request + incoming within Timeout, result is @true and parametres is filled with + information from request. You must handle this request, validate it, and + call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply + to TFTP Client.} + function WaitForRequest(var Req: word; var filename: string): Boolean; + + {:send error to TFTP client, when you acts as TFTP server.} + procedure ReplyError(Error: word; Description: string); + + {:Accept uploaded file from TFTP client to @link(data), when you acts as + TFTP server.} + function ReplyRecv: Boolean; + + {:Accept download request file from TFTP client and send content of + @link(data), when you acts as TFTP server.} + function ReplySend: Boolean; + published + {:Code of TFTP error.} + property ErrorCode: integer read FErrorCode; + + {:Human readable decription of TFTP error. (if is sended by remote side)} + property ErrorString: string read FErrorString; + + {:MemoryStream with datas for sending or receiving} + property Data: TMemoryStream read FData; + + {:Address of TFTP remote side.} + property RequestIP: string read FRequestIP write FRequestIP; + + {:Port of TFTP remote side.} + property RequestPort: string read FRequestPort write FRequestPort; + end; + +implementation + +constructor TTFTPSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTargetPort := cTFTPProtocol; + FData := TMemoryStream.Create; + FErrorCode := 0; + FErrorString := ''; +end; + +destructor TTFTPSend.Destroy; +begin + FSock.Free; + FData.Free; + inherited Destroy; +end; + +function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; +var + s, sh: string; +begin + FErrorCode := 0; + FErrorString := ''; + Result := false; + if Cmd <> 2 then + s := CodeInt(Cmd) + CodeInt(Serial) + Value + else + s := CodeInt(Cmd) + Value; + FSock.SendString(s); + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if length(s) >= 4 then + begin + sh := CodeInt(4) + CodeInt(Serial); + if Pos(sh, s) = 1 then + Result := True + else + if s[1] = #5 then + begin + FErrorCode := DecodeInt(s, 3); + Delete(s, 1, 4); + FErrorString := SeparateLeft(s, #0); + end; + end; +end; + +function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; +var + s: string; + ser: word; +begin + FErrorCode := 0; + FErrorString := ''; + Result := False; + Value := ''; + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if length(s) >= 4 then + if DecodeInt(s, 1) = 3 then + begin + ser := DecodeInt(s, 3); + if ser = Serial then + begin + Delete(s, 1, 4); + Value := s; + S := CodeInt(4) + CodeInt(ser); + FSock.SendString(s); + Result := FSock.LastError = 0; + end + else + begin + S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; + FSock.SendString(s); + end; + end; + if DecodeInt(s, 1) = 5 then + begin + FErrorCode := DecodeInt(s, 3); + Delete(s, 1, 4); + FErrorString := SeparateLeft(s, #0); + end; +end; + +function TTFTPSend.SendFile(const Filename: string): Boolean; +var + s: string; + ser: word; + n, n1, n2: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FTargetHost, FTargetPort); + try + if FSock.LastError = 0 then + begin + s := Filename + #0 + 'octet' + #0; + if not Sendpacket(2, 0, s) then + Exit; + ser := 1; + FData.Position := 0; + n1 := FData.Size div 512; + n2 := FData.Size mod 512; + for n := 1 to n1 do + begin + s := ReadStrFromStream(FData, 512); +// SetLength(s, 512); +// FData.Read(pointer(s)^, 512); + if not Sendpacket(3, ser, s) then + Exit; + inc(ser); + end; + s := ReadStrFromStream(FData, n2); +// SetLength(s, n2); +// FData.Read(pointer(s)^, n2); + if not Sendpacket(3, ser, s) then + Exit; + Result := True; + end; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.RecvFile(const Filename: string): Boolean; +var + s: string; + ser: word; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + FSock.Connect(FTargetHost, FTargetPort); + try + if FSock.LastError = 0 then + begin + s := CodeInt(1) + Filename + #0 + 'octet' + #0; + FSock.SendString(s); + if FSock.LastError <> 0 then + Exit; + FData.Clear; + ser := 1; + repeat + if not RecvPacket(ser, s) then + Exit; + inc(ser); + WriteStrToStream(FData, s); +// FData.Write(pointer(s)^, length(s)); + until length(s) <> 512; + FData.Position := 0; + Result := true; + end; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; +var + s: string; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + {$IFDEF ULTIBO} + FSock.EnableReuse(True); //Closed socket is not destroyed immediately, need to allow port reuse + {$ENDIF} + FSock.Bind('0.0.0.0', FTargetPort); + if FSock.LastError = 0 then + begin + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + if Length(s) >= 4 then + begin + FRequestIP := FSock.GetRemoteSinIP; + FRequestPort := IntToStr(FSock.GetRemoteSinPort); + Req := DecodeInt(s, 1); + delete(s, 1, 2); + filename := Trim(SeparateLeft(s, #0)); + s := SeparateRight(s, #0); + s := SeparateLeft(s, #0); + Result := lowercase(trim(s)) = 'octet'; + end; + end; +end; + +procedure TTFTPSend.ReplyError(Error: word; Description: string); +var + s: string; +begin + FSock.CloseSocket; + {$IFDEF ULTIBO} + FSock.EnableReuse(True); //Closed socket is not destroyed immediately, need to allow port reuse + FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to + {$ENDIF} + FSock.Connect(FRequestIP, FRequestPort); + s := CodeInt(5) + CodeInt(Error) + Description + #0; + FSock.SendString(s); + FSock.CloseSocket; +end; + +function TTFTPSend.ReplyRecv: Boolean; +var + s: string; + ser: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + {$IFDEF ULTIBO} + FSock.EnableReuse(True); //Closed socket is not destroyed immediately, need to allow port reuse + FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to + {$ENDIF} + FSock.Connect(FRequestIP, FRequestPort); + try + s := CodeInt(4) + CodeInt(0); + FSock.SendString(s); + FData.Clear; + ser := 1; + repeat + if not RecvPacket(ser, s) then + Exit; + inc(ser); + WriteStrToStream(FData, s); +// FData.Write(pointer(s)^, length(s)); + until length(s) <> 512; + FData.Position := 0; + Result := true; + finally + FSock.CloseSocket; + end; +end; + +function TTFTPSend.ReplySend: Boolean; +var + s: string; + ser: word; + n, n1, n2: integer; +begin + Result := False; + FErrorCode := 0; + FErrorString := ''; + FSock.CloseSocket; + {$IFDEF ULTIBO} + FSock.EnableReuse(True); //Closed socket is not destroyed immediately, need to allow port reuse + FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to + {$ENDIF} + FSock.Connect(FRequestIP, FRequestPort); + try + ser := 1; + FData.Position := 0; + n1 := FData.Size div 512; + n2 := FData.Size mod 512; + for n := 1 to n1 do + begin + s := ReadStrFromStream(FData, 512); +// SetLength(s, 512); +// FData.Read(pointer(s)^, 512); + if not Sendpacket(3, ser, s) then + Exit; + inc(ser); + end; + s := ReadStrFromStream(FData, n2); +// SetLength(s, n2); +// FData.Read(pointer(s)^, n2); + if not Sendpacket(3, ser, s) then + Exit; + Result := True; + finally + FSock.CloseSocket; + end; +end; + +{==============================================================================} + +end. diff --git a/httpsend.pas b/httpsend.pas new file mode 100644 index 0000000..7057ab0 --- /dev/null +++ b/httpsend.pas @@ -0,0 +1,866 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.012.009 | +|==============================================================================| +| Content: HTTP client | +|==============================================================================| +| Copyright (c)1999-2015, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2015. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(HTTP protocol client) + +Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit httpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synabyte, synaip, synacode, synsock; + +const + cHttpProtocol = '80'; + +type + {:These encoding types are used internally by the THTTPSend object to identify + the transfer data types.} + TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED); + + {:abstract(Implementation of HTTP protocol.)} + THTTPSend = class(TSynaClient) + private + FConnectionTimeOut: Integer; + FIgnoreBody: Boolean; + protected + FSock: TTCPBlockSocket; + FTransferEncoding: TTransferEncoding; + FAliveHost: string; + FAlivePort: string; + FHeaders: TStringList; + FDocument: TMemoryStream; + FMimeType: string; + FProtocol: string; + FKeepAlive: Boolean; + FKeepAliveTimeout: integer; + FStatus100: Boolean; + FProxyHost: string; + FProxyPort: string; + FProxyUser: string; + FProxyPass: string; + FResultCode: Integer; + FResultString: string; + FUserAgent: string; + FCookies: TStringList; + FDownloadSize: integer; + FUploadSize: integer; + FRangeStart: integer; + FRangeEnd: integer; + FAddPortNumberToHost: Boolean; + function ReadUnknown: Boolean; virtual; + function ReadIdentity(Size: Integer): Boolean; virtual; + function ReadChunked: Boolean; virtual; + procedure ParseCookies; + function PrepareHeaders: String; + function InternalDoConnect(needssl: Boolean): Boolean; + function InternalConnect(needssl: Boolean): Boolean; + public + constructor Create; + destructor Destroy; override; + + {:Reset headers, document and Mimetype.} + procedure Clear; + + {:Decode ResultCode and ResultString from Value.} + procedure DecodeStatus(const Value: string); + + {:Connects to host defined in URL and accesses resource defined in URL by + method. If Document is not empty, send it to the server as part of the HTTP + request. Server response is in Document and headers. Connection may be + authorised by username and password in URL. If you define proxy properties, + connection is made by this proxy. + If all OK, result is @true, else result is @false. + + If you use 'https:' instead of 'http:' in the URL, your request is made + by SSL/TLS connection (if you do not specify port, then port 443 is used + instead of standard port 80). If you use SSL/TLS request and you have + defined HTTP proxy, then HTTP-tunnel mode is automatically used .} + function HTTPMethod(const Method, URL: string): Boolean; + + {:You can call this method from OnStatus event to break current data + transfer. (or from another thread.)} + procedure Abort; + published + {:Before HTTP operation you may define any non-standard headers for HTTP + request, except: 'Expect: 100-continue', 'Content-Length', 'Content-Type', + 'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers. + After HTTP operation, it contains full headers of the returned document.} + property Headers: TStringList read FHeaders; + + {:Stringlist with name-value stringlist pairs. Each pair is one cookie. + After the HTTP request is returned, cookies are parsed to this stringlist. + You can leave these cookies untouched for next HTTP requests. You can also + save this stringlist for later use.} + property Cookies: TStringList read FCookies; + + {:Stream with document to send (before request), or with document received + from HTTP server (after request).} + property Document: TMemoryStream read FDocument; + + {:If you need to download only part of a requested document, specify here + the position of subpart begin. If 0, the full document is requested.} + property RangeStart: integer read FRangeStart Write FRangeStart; + + {:If you need to download only part of a requested document, specify here + the position of subpart end. If 0, the document from rangeStart to end of + document is requested. + (Useful for resuming broken downloads, for example.)} + property RangeEnd: integer read FRangeEnd Write FRangeEnd; + + {:Mime type of sending data. Default is: 'text/html'.} + property MimeType: string read FMimeType Write FMimeType; + + {:Define protocol version. Possible values are: '1.1', '1.0' (default) + and '0.9'.} + property Protocol: string read FProtocol Write FProtocol; + + {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.} + property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; + + {:Define timeout for keepalives in seconds!} + property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout; + + {:if @true, then the server is requested for 100status capability when + uploading data. Default is @false (off).} + property Status100: Boolean read FStatus100 Write FStatus100; + + {:Address of proxy server (IP address or domain name) where you want to + connect in @link(HTTPMethod) method.} + property ProxyHost: string read FProxyHost Write FProxyHost; + + {:Port number for proxy connection. Default value is 8080.} + property ProxyPort: string read FProxyPort Write FProxyPort; + + {:Username for connection to proxy server used in HTTPMethod method.} + property ProxyUser: string read FProxyUser Write FProxyUser; + + {:Password for connection to proxy server used in HTTPMethod method.} + property ProxyPass: string read FProxyPass Write FProxyPass; + + {:Here you can specify custom User-Agent identification. + Default: 'Mozilla/4.0 (compatible; Synapse)'} + property UserAgent: string read FUserAgent Write FUserAgent; + + {:Operation result code after successful @link(HTTPMethod) method.} + property ResultCode: Integer read FResultCode; + + {:Operation result string after successful @link(HTTPMethod) method.} + property ResultString: string read FResultString; + + {:if this value is not 0, then data download is pending. In this case you + have here the total size of downloaded data. Useful for drawing download + progressbar from OnStatus event.} + property DownloadSize: integer read FDownloadSize; + + {:if this value is not 0, then data upload is pending. In this case you have + here the total size of uploaded data. Useful for drawing upload progressbar + from OnStatus event.} + property UploadSize: integer read FUploadSize; + + {:Socket object used for TCP/IP operation. + Good for setting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE. + Some buggy servers do not like port informations in this header.} + property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost; + + property ConnectionTimeOut: Integer read FConnectionTimeOut + write FConnectionTimeOut; + + property IgnoreBody: Boolean read FIgnoreBody write FIgnoreBody; + end; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the GET method of the HTTP protocol. This function sends + the GET method for URL document to an HTTP server. Returned document is in the + "Response" stringlist (without any headers). Returns boolean TRUE if all went + well.} +function HttpGetText(const URL: string; const Response: TStrings): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the GET method of the HTTP protocol. This function sends + the GET method for URL document to an HTTP server. Returned document is in the + "Response" stream. Returns boolean TRUE if all went well.} +function HttpGetBinary(const URL: string; const Response: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function sends + the SEND method for a URL document to an HTTP server. The document to be sent + is located in the "Data" stream. The returned document is in the "Data" stream. + Returns boolean TRUE if all went well.} +function HttpPostBinary(const URL: string; const Data: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function is + good for POSTing form data. It sends the POST method for a URL document to + an HTTP server. You must prepare the form data in the same manner as you would + the URL data, and pass this prepared data to "URLdata". The following is + a sample of how the data would appear: 'name=Lukas&field1=some%20data'. + The information in the field must be encoded by the EncodeURLElement function. + The returned document is in the "Data" stream. Returns boolean TRUE if all + went well.} +function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function sends + the POST method for a URL document to an HTTP server. This function simulates + posting of file by HTML form using the 'multipart/form-data' method. The posted + file is in the DATA stream. Its name is Filename string. Fieldname is for the + name of the form field with the file. (simulates HTML INPUT FILE) The returned + document is in the ResultData Stringlist. Returns boolean TRUE if all + went well.} +function HttpPostFile(const URL, FieldName, FileName: string; + const Data: TStream; const ResultData: TStrings): Boolean; + +implementation + +constructor THTTPSend.Create; +begin + inherited Create; + FHeaders := TStringList.Create; + FCookies := TStringList.Create; + FDocument := TMemoryStream.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := True; + FSock.SizeRecvBuffer := c64k; + FSock.SizeSendBuffer := c64k; + FTimeout := 90000; + FTargetPort := cHttpProtocol; + FProxyHost := ''; + FProxyPort := '8080'; + FProxyUser := ''; + FProxyPass := ''; + FAliveHost := ''; + FAlivePort := ''; + FProtocol := '1.0'; + FKeepAlive := True; + FStatus100 := False; + FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; + FDownloadSize := 0; + FUploadSize := 0; + FAddPortNumberToHost := true; + FKeepAliveTimeout := 300; + + FConnectionTimeOut := 0; + Clear; +end; + +destructor THTTPSend.Destroy; +begin + FSock.Free; + FDocument.Free; + FCookies.Free; + FHeaders.Free; + inherited Destroy; +end; + +procedure THTTPSend.Clear; +begin + FRangeStart := 0; + FRangeEnd := 0; + FDocument.Clear; + FHeaders.Clear; + FMimeType := 'text/html'; +end; + +procedure THTTPSend.DecodeStatus(const Value: string); +var + s, su: string; +begin + s := Trim(SeparateRight(Value, ' ')); + su := Trim(SeparateLeft(s, ' ')); + FResultCode := StrToIntDef(su, 0); + FResultString := Trim(SeparateRight(s, ' ')); + if FResultString = s then + FResultString := ''; +end; + +function THTTPSend.PrepareHeaders: String; +begin + if FProtocol = '0.9' then + Result := FHeaders[0] + CRLF + else +{$IFNDEF MSWINDOWS} + Result := {$IFDEF UNICODE}TMarshal.AsAnsi{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF)); +{$ELSE} + Result := FHeaders.Text; +{$ENDIF} +end; + +function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + FSock.ConnectionTimeOut := FConnectionTimeOut; + + if FSock.LastError <> 0 then + Exit; + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError <> 0 then + Exit; + if needssl then + begin + if (FSock.SSL.SNIHost='') then + FSock.SSL.SNIHost:=FTargetHost; + FSock.SSLDoConnect; + FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection + if FSock.LastError <> 0 then + Exit; + end; + FAliveHost := FTargetHost; + FAlivePort := FTargetPort; + Result := True; +end; + +function THTTPSend.InternalConnect(needssl: Boolean): Boolean; +begin + if FSock.Socket = INVALID_SOCKET then + Result := InternalDoConnect(needssl) + else + if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) + or FSock.CanRead(0) then + Result := InternalDoConnect(needssl) + else + Result := True; +end; + +function THTTPSend.HTTPMethod(const Method, URL: string): Boolean; +var + Sending, Receiving: Boolean; + status100: Boolean; + status100error: string; + ToClose: Boolean; + Size: Integer; + Prot, User, Pass, Host, Port, Path, Para, URI: string; + s, su: String; + HttpTunnel: Boolean; + n: integer; + pp: string; + UsingProxy: boolean; + l: TStringList; + x: integer; +begin + {initial values} + Result := False; + FResultCode := 500; + FResultString := ''; + FDownloadSize := 0; + FUploadSize := 0; + + URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); + User := DecodeURL(user); + Pass := DecodeURL(pass); + if User = '' then + begin + User := FUsername; + Pass := FPassword; + end; + if UpperCase(Prot) = 'HTTPS' then + begin + HttpTunnel := FProxyHost <> ''; + FSock.HTTPTunnelIP := FProxyHost; + FSock.HTTPTunnelPort := FProxyPort; + FSock.HTTPTunnelUser := FProxyUser; + FSock.HTTPTunnelPass := FProxyPass; + end + else + begin + HttpTunnel := False; + FSock.HTTPTunnelIP := ''; + FSock.HTTPTunnelPort := ''; + FSock.HTTPTunnelUser := ''; + FSock.HTTPTunnelPass := ''; + end; + UsingProxy := (FProxyHost <> '') and not(HttpTunnel); + Sending := FDocument.Size > 0; + {Headers for Sending data} + status100 := FStatus100 and Sending and (FProtocol = '1.1'); + if status100 then + FHeaders.Insert(0, 'Expect: 100-continue'); + if Sending then + begin + FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); + if FMimeType <> '' then + FHeaders.Insert(0, 'Content-Type: ' + FMimeType); + end; + { setting User-agent } + if FUserAgent <> '' then + FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); + { setting Ranges } + if (FRangeStart > 0) or (FRangeEnd > 0) then + begin + if FRangeEnd >= FRangeStart then + FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)) + else + FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-'); + end; + { setting Cookies } + s := ''; + for n := 0 to FCookies.Count - 1 do + begin + if s <> '' then + s := s + '; '; + s := s + FCookies[n]; + end; + if s <> '' then + FHeaders.Insert(0, 'Cookie: ' + s); + { setting KeepAlives } + pp := ''; + if UsingProxy then + pp := 'Proxy-'; + if FKeepAlive then + begin + FHeaders.Insert(0, pp + 'Connection: keep-alive'); + FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout)); + end + else + FHeaders.Insert(0, pp + 'Connection: close'); + { set target servers/proxy, authorizations, etc... } + if (User <> '') or (Pass <> '') then + FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass)); + if UsingProxy and (FProxyUser <> '') then + FHeaders.Insert(0, 'Proxy-Authorization: Basic ' + + EncodeBase64(FProxyUser + ':' + FProxyPass)); + if isIP6(Host) then + s := '[' + Host + ']' + else + s := Host; + if FAddPortNumberToHost + and (((Port <> '80') and (UpperCase(Prot) = 'HTTP')) + or ((Port <> '443') and (UpperCase(Prot) = 'HTTPS'))) then + FHeaders.Insert(0, 'Host: ' + s + ':' + Port) + else + FHeaders.Insert(0, 'Host: ' + s); + if UsingProxy then + URI := Prot + '://' + s + ':' + Port + URI; + if URI = '/*' then + URI := '*'; + if FProtocol = '0.9' then + FHeaders.Insert(0, UpperCase(Method) + ' ' + URI) + else + FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); + if UsingProxy then + begin + FTargetHost := FProxyHost; + FTargetPort := FProxyPort; + end + else + begin + FTargetHost := Host; + FTargetPort := Port; + end; + if FHeaders[FHeaders.Count - 1] <> '' then + FHeaders.Add(''); + + { connect } + if not InternalConnect(UpperCase(Prot) = 'HTTPS') then + begin + FAliveHost := ''; + FAlivePort := ''; + Exit; + end; + + { reading Status } + FDocument.Position := 0; + Status100Error := ''; + if status100 then + begin + { send Headers } + FSock.SendString(PrepareHeaders); + if FSock.LastError <> 0 then + Exit; + repeat + s := FSock.RecvString(FTimeout); + if s <> '' then + Break; + until FSock.LastError <> 0; + DecodeStatus(s); + Status100Error := s; + repeat + s := FSock.recvstring(FTimeout); + if s = '' then + Break; + until FSock.LastError <> 0; + if (FResultCode >= 100) and (FResultCode < 200) then + begin + { we can upload content } + Status100Error := ''; + FUploadSize := FDocument.Size; + FSock.SendBuffer(FDocument.Memory, FDocument.Size); + end; + end + else + { upload content } + if sending then + begin + if FDocument.Size >= c64k then + begin + FSock.SendString(PrepareHeaders); + FUploadSize := FDocument.Size; + FSock.SendBuffer(FDocument.Memory, FDocument.Size); + end + else + begin + s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size); + FUploadSize := Length(s); + FSock.SendString(s); + end; + end + else + begin + { we not need to upload document, send headers only } + FSock.SendString(PrepareHeaders); + end; + + if FSock.LastError <> 0 then + Exit; + + Clear; + Size := -1; + FTransferEncoding := TE_UNKNOWN; + + { read status } + if Status100Error = '' then + begin + repeat + repeat + s := FSock.RecvString(FTimeout); + if s <> '' then + Break; + until FSock.LastError <> 0; + if Pos('HTTP/', UpperCase(s)) = 1 then + begin + FHeaders.Add(s); + DecodeStatus(s); + end + else + begin + { old HTTP 0.9 and some buggy servers not send result } + s := s + CRLF; + WriteStrToStream(FDocument, s); + FResultCode := 0; + end; + until (FSock.LastError <> 0) or (FResultCode <> 100); + end + else + FHeaders.Add(Status100Error); + + { if need receive headers, receive and parse it } + ToClose := FProtocol <> '1.1'; + if FHeaders.Count > 0 then + begin + l := TStringList.Create; + try + repeat + s := FSock.RecvString(FTimeout); + l.Add(s); + if s = '' then + Break; + until FSock.LastError <> 0; + x := 0; + while l.Count > x do + begin + s := NormalizeHeader(l, x); + FHeaders.Add(s); + su := UpperCase(s); + if Pos('CONTENT-LENGTH:', su) = 1 then + begin + Size := StrToIntDef(Trim(SeparateRight(s, ':')), -1); + if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then + FTransferEncoding := TE_IDENTITY; + end; + if Pos('CONTENT-TYPE:', su) = 1 then + FMimeType := Trim(SeparateRight(s, ':')); + if Pos('TRANSFER-ENCODING:', su) = 1 then + begin + s := Trim(SeparateRight(su, ':')); + if Pos('CHUNKED', s) > 0 then + FTransferEncoding := TE_CHUNKED; + end; + if UsingProxy then + begin + if Pos('PROXY-CONNECTION:', su) = 1 then + if Pos('CLOSE', su) > 0 then + ToClose := True; + end + else + begin + if Pos('CONNECTION:', su) = 1 then + if Pos('CLOSE', su) > 0 then + ToClose := True; + end; + end; + finally + l.free; + end; + end; + + Result := FSock.LastError = 0; + if not Result then + begin + FSock.CloseSocket; + FAliveHost := ''; + FAlivePort := ''; + Exit; + end; + + {if need receive response body, read it} + Receiving := Method <> 'HEAD'; + Receiving := Receiving and (FResultCode <> 204); + Receiving := Receiving and (FResultCode <> 304); + if Receiving then + case FTransferEncoding of + TE_UNKNOWN: + Result := ReadUnknown; + TE_IDENTITY: + Result := ReadIdentity(Size); + TE_CHUNKED: + Result := ReadChunked; + end; + + FDocument.Position := 0; + if ToClose then + begin + FSock.CloseSocket; + FAliveHost := ''; + FAlivePort := ''; + end; + ParseCookies; +end; + +function THTTPSend.ReadUnknown: Boolean; +var + s: TSynaBytes; +begin + Result := false; + repeat + s := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + WriteStrToStream(FDocument, s); + until FSock.LastError <> 0; + if FSock.LastError = WSAECONNRESET then + begin + Result := true; + FSock.ResetLastError; + end; +end; + +function THTTPSend.ReadIdentity(Size: Integer): Boolean; +begin + if Size > 0 then + begin + FDownloadSize := Size; + FSock.RecvStreamSize(FDocument, FTimeout, Size); + FDocument.Position := FDocument.Size; + Result := FSock.LastError = 0; + end + else + Result := true; +end; + +function THTTPSend.ReadChunked: Boolean; +var + s: string; + Size: Integer; +begin + repeat + repeat + s := FSock.RecvString(FTimeout); + until (s <> '') or (FSock.LastError <> 0); + if FSock.LastError <> 0 then + Break; + s := Trim(SeparateLeft(s, ' ')); + s := Trim(SeparateLeft(s, ';')); + Size := StrToIntDef('$' + s, 0); + if Size = 0 then + Break; + if not ReadIdentity(Size) then + break; + until False; + Result := FSock.LastError = 0; +end; + +procedure THTTPSend.ParseCookies; +var + n: integer; + s: string; + sn, sv: string; +begin + for n := 0 to FHeaders.Count - 1 do + if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then + begin + s := SeparateRight(FHeaders[n], ':'); + s := trim(SeparateLeft(s, ';')); + sn := trim(SeparateLeft(s, '=')); + sv := trim(SeparateRight(s, '=')); + FCookies.Values[sn] := sv; + end; +end; + +procedure THTTPSend.Abort; +begin + FSock.StopFlag := True; +end; + +{==============================================================================} + +function HttpGetText(const URL: string; const Response: TStrings): Boolean; +var + HTTP: THTTPSend; +begin + HTTP := THTTPSend.Create; + try + Result := HTTP.HTTPMethod('GET', URL); + if Result then + Response.LoadFromStream(HTTP.Document + {$IFDEF UNICODE}, TEncoding.ANSI{$ENDIF}); + finally + HTTP.Free; + end; +end; + +function HttpGetBinary(const URL: string; const Response: TStream): Boolean; +var + HTTP: THTTPSend; +begin + HTTP := THTTPSend.Create; + try + Result := HTTP.HTTPMethod('GET', URL); + if Result then + begin + Response.Position := 0; + Response.CopyFrom(HTTP.Document, 0); + end; + finally + HTTP.Free; + end; +end; + +function HttpPostBinary(const URL: string; const Data: TStream): Boolean; +var + HTTP: THTTPSend; +begin + HTTP := THTTPSend.Create; + try + HTTP.Document.CopyFrom(Data, 0); + HTTP.MimeType := 'Application/octet-stream'; + Result := HTTP.HTTPMethod('POST', URL); + Data.Size := 0; + if Result then + begin + Data.Position := 0; + Data.CopyFrom(HTTP.Document, 0); + end; + finally + HTTP.Free; + end; +end; + +function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; +var + HTTP: THTTPSend; +begin + HTTP := THTTPSend.Create; + try + WriteStrToStream(HTTP.Document, URLData); + HTTP.MimeType := 'application/x-www-form-urlencoded'; + Result := HTTP.HTTPMethod('POST', URL); + if Result then + Data.CopyFrom(HTTP.Document, 0); + finally + HTTP.Free; + end; +end; + +function HttpPostFile(const URL, FieldName, FileName: string; + const Data: TStream; const ResultData: TStrings): Boolean; +var + HTTP: THTTPSend; + Bound, s: string; +begin + Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; + HTTP := THTTPSend.Create; + try + s := '--' + Bound + CRLF; + s := s + 'content-disposition: form-data; name="' + FieldName + '";'; + s := s + ' filename="' + FileName +'"' + CRLF; + s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; + WriteStrToStream(HTTP.Document, s); + HTTP.Document.CopyFrom(Data, 0); + s := CRLF + '--' + Bound + '--' + CRLF; + WriteStrToStream(HTTP.Document, s); + HTTP.MimeType := 'multipart/form-data; boundary=' + Bound; + Result := HTTP.HTTPMethod('POST', URL); + if Result then + ResultData.LoadFromStream(HTTP.Document); + finally + HTTP.Free; + end; +end; + +end. diff --git a/imapsend.pas b/imapsend.pas new file mode 100644 index 0000000..43f1f76 --- /dev/null +++ b/imapsend.pas @@ -0,0 +1,871 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.005.004 | +|==============================================================================| +| Content: IMAP4rev1 client | +|==============================================================================| +| Copyright (c)1999-2015, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001-2015. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(IMAP4 rev1 protocol client) + +Used RFC: RFC-2060, RFC-2595 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit imapsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cIMAPProtocol = '143'; + +type + {:@abstract(Implementation of IMAP4 protocol.) + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TIMAPSend = class(TSynaClient) + protected + FSock: TTCPBlockSocket; + FTagCommand: integer; + FResultString: string; + FFullResult: TStringList; + FIMAPcap: TStringList; + FAuthDone: Boolean; + FSelectedFolder: string; + FSelectedCount: integer; + FSelectedRecent: integer; + FSelectedUIDvalidity: integer; + FUID: Boolean; + FAutoTLS: Boolean; + FFullSSL: Boolean; + function ReadResult: string; + function AuthLogin: Boolean; + function Connect: Boolean; + procedure ParseMess(Value:TStrings); + procedure ParseFolderList(Value:TStrings); + procedure ParseSelect; + procedure ParseSearch(Value:TStrings); + procedure ProcessLiterals; + public + constructor Create; + destructor Destroy; override; + + {:By this function you can call any IMAP command. Result of this command is + in adequate properties.} + function IMAPcommand(Value: string): string; + + {:By this function you can call any IMAP command what need upload any data. + Result of this command is in adequate properties.} + function IMAPuploadCommand(Value: string; const Data:TStrings): string; + + {:Call CAPABILITY command and fill IMAPcap property by new values.} + function Capability: Boolean; + + {:Connect to IMAP server and do login to this server. This command begin + session.} + function Login: Boolean; + + {:Disconnect from IMAP server and terminate session session. If exists some + deleted and non-purged messages, these messages are not deleted!} + function Logout: Boolean; + + {:Do NOOP. It is for prevent disconnect by timeout.} + function NoOp: Boolean; + + {:Lists folder names. You may specify level of listing. If you specify + FromFolder as empty string, return is all folders in system.} + function List(FromFolder: string; const FolderList: TStrings): Boolean; + + {:Lists folder names what match search criteria. You may specify level of + listing. If you specify FromFolder as empty string, return is all folders + in system.} + function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; + + {:Lists subscribed folder names. You may specify level of listing. If you + specify FromFolder as empty string, return is all subscribed folders in + system.} + function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; + + {:Lists subscribed folder names what matching search criteria. You may + specify level of listing. If you specify FromFolder as empty string, return + is all subscribed folders in system.} + function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; + + {:Create a new folder.} + function CreateFolder(FolderName: string): Boolean; + + {:Delete a folder.} + function DeleteFolder(FolderName: string): Boolean; + + {:Rename folder names.} + function RenameFolder(FolderName, NewFolderName: string): Boolean; + + {:Subscribe folder.} + function SubscribeFolder(FolderName: string): Boolean; + + {:Unsubscribe folder.} + function UnsubscribeFolder(FolderName: string): Boolean; + + {:Select folder.} + function SelectFolder(FolderName: string): Boolean; + + {:Select folder, but only for reading. Any changes are not allowed!} + function SelectROFolder(FolderName: string): Boolean; + + {:Close a folder. (end of Selected state)} + function CloseFolder: Boolean; + + {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN', + result is number of unseen messages in folder. For another status + indentificator check IMAP documentation and documentation of your IMAP + server (each IMAP server can have their own statuses.)} + function StatusFolder(FolderName, Value: string): integer; + + {:Hardly delete all messages marked as 'deleted' in current selected folder.} + function ExpungeFolder: Boolean; + + {:Touch to folder. (use as update status of folder, etc.)} + function CheckFolder: Boolean; + + {:Append given message to specified folder.} + function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; + + {:'Delete' message from current selected folder. It mark message as Deleted. + Real deleting will be done after sucessfull @link(CloseFolder) or + @link(ExpungeFolder)} + function DeleteMess(MessID: integer): boolean; + + {:Get full message from specified message in selected folder.} + function FetchMess(MessID: integer; const Mess: TStrings): Boolean; + + {:Get message headers only from specified message in selected folder.} + function FetchHeader(MessID: integer; const Headers: TStrings): Boolean; + + {:Return message size of specified message from current selected folder.} + function MessageSize(MessID: integer): integer; + + {:Copy message from current selected folder to another folder.} + function CopyMess(MessID: integer; ToFolder: string): Boolean; + + {:Return message numbers from currently selected folder as result + of searching. Search criteria is very complex language (see to IMAP + specification) similar to SQL (but not same syntax!).} + function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; + + {:Sets flags of message from current selected folder.} + function SetFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Gets flags of message from current selected folder.} + function GetFlagsMess(MessID: integer; var Flags: string): Boolean; + + {:Add flags to message's flags.} + function AddFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Remove flags from message's flags.} + function DelFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:return UID of requested message ID.} + function GetUID(MessID: integer; var UID : Integer): Boolean; + + {:Try to find given capabily in capabilty string returned from IMAP server.} + function FindCap(const Value: string): string; + published + {:Status line with result of last operation.} + property ResultString: string read FResultString; + + {:Full result of last IMAP operation.} + property FullResult: TStringList read FFullResult; + + {:List of server capabilites.} + property IMAPcap: TStringList read FIMAPcap; + + {:Authorization is successful done.} + property AuthDone: Boolean read FAuthDone; + + {:Turn on or off usage of UID (unicate identificator) of messages instead + only sequence numbers.} + property UID: Boolean read FUID Write FUID; + + {:Name of currently selected folder.} + property SelectedFolder: string read FSelectedFolder; + + {:Count of messages in currently selected folder.} + property SelectedCount: integer read FSelectedCount; + + {:Count of not-visited messages in currently selected folder.} + property SelectedRecent: integer read FSelectedRecent; + + {:This number with name of folder is unique indentificator of folder. + (If someone delete folder and next create new folder with exactly same name + of folder, this number is must be different!)} + property SelectedUIDvalidity: integer read FSelectedUIDvalidity; + + {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + end; + +implementation + +constructor TIMAPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FIMAPcap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := True; + FSock.SizeRecvBuffer := 32768; + FSock.SizeSendBuffer := 32768; + FTimeout := 60000; + FTargetPort := cIMAPProtocol; + FTagCommand := 0; + FSelectedFolder := ''; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + FUID := False; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TIMAPSend.Destroy; +begin + FSock.Free; + FIMAPcap.Free; + FFullResult.Free; + inherited Destroy; +end; + + +function TIMAPSend.ReadResult: string; +var + s: string; + x, l: integer; +begin + Result := ''; + FFullResult.Clear; + FResultString := ''; + repeat + s := FSock.RecvString(FTimeout); + if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then + begin + FResultString := s; + break; + end + else + FFullResult.Add(s); + if (s <> '') and (s[Length(s)]='}') then + begin + s := Copy(s, 1, Length(s) - 1); + x := RPos('{', s); + s := Copy(s, x + 1, Length(s) - x); + l := StrToIntDef(s, -1); + if l <> -1 then + begin + s := FSock.RecvBufferStr(l, FTimeout); + FFullResult.Add(s); + end; + end; + until FSock.LastError <> 0; + s := Trim(separateright(FResultString, ' ')); + Result:=uppercase(Trim(separateleft(s, ' '))); +end; + +procedure TIMAPSend.ProcessLiterals; +var + l: TStringList; + n, x: integer; + b: integer; + s: string; +begin + l := TStringList.Create; + try + l.Assign(FFullResult); + FFullResult.Clear; + b := 0; + for n := 0 to l.Count - 1 do + begin + s := l[n]; + if b > 0 then + begin + FFullResult[FFullresult.Count - 1] := + FFullResult[FFullresult.Count - 1] + s; + inc(b); + if b > 2 then + b := 0; + end + else + begin + if (s <> '') and (s[Length(s)]='}') then + begin + x := RPos('{', s); + Delete(s, x, Length(s) - x + 1); + b := 1; + end + else + b := 0; + FFullResult.Add(s); + end; + end; + finally + l.Free; + end; +end; + +function TIMAPSend.IMAPcommand(Value: string): string; +begin + Inc(FTagCommand); + FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF); + Result := ReadResult; +end; + +function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string; +var + l: integer; +begin + Inc(FTagCommand); + l := Length(Data.Text); + FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); + FSock.RecvString(FTimeout); + FSock.SendString(Data.Text + CRLF); + Result := ReadResult; +end; + +procedure TIMAPSend.ParseMess(Value:TStrings); +var + n: integer; +begin + Value.Clear; + for n := 0 to FFullResult.Count - 2 do + if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then + begin + Value.Text := FFullResult[n + 1]; + Break; + end; +end; + +procedure TIMAPSend.ParseFolderList(Value:TStrings); +var + n, x: integer; + s: string; +begin + ProcessLiterals; + Value.Clear; + for n := 0 to FFullResult.Count - 1 do + begin + s := FFullResult[n]; + if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then + begin + if s[Length(s)] = '"' then + begin + Delete(s, Length(s), 1); + x := RPos('"', s); + end + else + x := RPos(' ', s); + if (x > 0) then + Value.Add(Copy(s, x + 1, Length(s) - x)); + end; + end; +end; + +procedure TIMAPSend.ParseSelect; +var + n: integer; + s, t: string; +begin + ProcessLiterals; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos(' EXISTS', s) > 0 then + begin + t := Trim(separateleft(s, ' EXISTS')); + t := Trim(separateright(t, '* ')); + FSelectedCount := StrToIntDef(t, 0); + end; + if Pos(' RECENT', s) > 0 then + begin + t := Trim(separateleft(s, ' RECENT')); + t := Trim(separateright(t, '* ')); + FSelectedRecent := StrToIntDef(t, 0); + end; + if Pos('UIDVALIDITY', s) > 0 then + begin + t := Trim(separateright(s, 'UIDVALIDITY ')); + t := Trim(separateleft(t, ']')); + FSelectedUIDvalidity := StrToIntDef(t, 0); + end; + end; +end; + +procedure TIMAPSend.ParseSearch(Value:TStrings); +var + n: integer; + s: string; +begin + ProcessLiterals; + Value.Clear; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos('* SEARCH', s) = 1 then + begin + s := Trim(SeparateRight(s, '* SEARCH')); + while s <> '' do + Value.Add(Fetch(s, ' ')); + end; + end; +end; + +function TIMAPSend.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FIMAPcap.Count - 1 do + if Pos(s, UpperCase(FIMAPcap[n])) = 1 then + begin + Result := FIMAPcap[n]; + Break; + end; +end; + +function TIMAPSend.AuthLogin: Boolean; +begin + Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK'; + if Result then + FAuthDone := True; +end; + +function TIMAPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TIMAPSend.Capability: Boolean; +var + n: Integer; + s, t: string; +begin + Result := False; + FIMAPcap.Clear; + s := IMAPcommand('CAPABILITY'); + if s = 'OK' then + begin + ProcessLiterals; + for n := 0 to FFullResult.Count - 1 do + if Pos('* CAPABILITY ', FFullResult[n]) = 1 then + begin + s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY ')); + while not (s = '') do + begin + t := Trim(separateleft(s, ' ')); + s := Trim(separateright(s, ' ')); + if s = t then + s := ''; + FIMAPcap.Add(t); + end; + end; + Result := True; + end; +end; + +function TIMAPSend.Login: Boolean; +var + s: string; +begin + FSelectedFolder := ''; + FSelectedCount := 0; + FSelectedRecent := 0; + FSelectedUIDvalidity := 0; + Result := False; + FAuthDone := False; + if not Connect then + Exit; + s := FSock.RecvString(FTimeout); + if Pos('* PREAUTH', s) = 1 then + FAuthDone := True + else + if Pos('* OK', s) = 1 then + FAuthDone := False + else + Exit; + if Capability then + begin + if Findcap('IMAP4rev1') = '' then + Exit; + if FAutoTLS and (Findcap('STARTTLS') <> '') then + if StartTLS then + Capability; + end; + Result := AuthLogin; +end; + +function TIMAPSend.Logout: Boolean; +begin + Result := IMAPcommand('LOGOUT') = 'OK'; + FSelectedFolder := ''; + FSock.CloseSocket; +end; + +function TIMAPSend.NoOp: Boolean; +begin + Result := IMAPcommand('NOOP') = 'OK'; +end; + +function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK'; + ParseFolderList(FolderList); +end; + +function TIMAPSend.CreateFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.DeleteFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean; +begin + Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK'; +end; + +function TIMAPSend.SubscribeFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK'; +end; + +function TIMAPSend.SelectFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK'; + FSelectedFolder := FolderName; + ParseSelect; +end; + +function TIMAPSend.SelectROFolder(FolderName: string): Boolean; +begin + Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK'; + FSelectedFolder := FolderName; + ParseSelect; +end; + +function TIMAPSend.CloseFolder: Boolean; +begin + Result := IMAPcommand('CLOSE') = 'OK'; + FSelectedFolder := ''; +end; + +function TIMAPSend.StatusFolder(FolderName, Value: string): integer; +var + n: integer; + s, t: string; +begin + Result := -1; + Value := Uppercase(Value); + if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then + begin + ProcessLiterals; + for n := 0 to FFullResult.Count - 1 do + begin + s := FFullResult[n]; +// s := UpperCase(FFullResult[n]); + if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then + begin + t := SeparateRight(s, Value); + t := SeparateLeft(t, ')'); + t := trim(t); + Result := StrToIntDef(t, -1); + Break; + end; + end; + end; +end; + +function TIMAPSend.ExpungeFolder: Boolean; +begin + Result := IMAPcommand('EXPUNGE') = 'OK'; +end; + +function TIMAPSend.CheckFolder: Boolean; +begin + Result := IMAPcommand('CHECK') = 'OK'; +end; + +function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean; +begin + Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK'; +end; + +function TIMAPSend.DeleteMess(MessID: integer): boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean; +var + s: string; +begin + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseMess(Mess); +end; + +function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean; +var + s: string; +begin + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseMess(Headers); +end; + +function TIMAPSend.MessageSize(MessID: integer): integer; +var + n: integer; + s, t: string; +begin + Result := -1; + s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)'; + if FUID then + s := 'UID ' + s; + if IMAPcommand(s) = 'OK' then + begin + ProcessLiterals; + for n := 0 to FFullResult.Count - 1 do + begin + s := UpperCase(FFullResult[n]); + if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then + begin + t := SeparateRight(s, 'RFC822.SIZE '); + t := Trim(SeparateLeft(t, ')')); + t := Trim(SeparateLeft(t, ' ')); + Result := StrToIntDef(t, -1); + Break; + end; + end; + end; +end; + +function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean; +var + s: string; +begin + s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; +var + s: string; +begin + s := 'SEARCH ' + Criteria; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ParseSearch(FoundMess); +end; + +function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean; +var + s: string; +begin + s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; +end; + +function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean; +var + s: string; + n: integer; +begin + Flags := ''; + s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)'; + if FUID then + s := 'UID ' + s; + Result := IMAPcommand(s) = 'OK'; + ProcessLiterals; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then + begin + s := SeparateRight(s, 'FLAGS'); + s := Separateright(s, '('); + Flags := Trim(SeparateLeft(s, ')')); + end; + end; +end; + +function TIMAPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + if IMAPcommand('STARTTLS') = 'OK' then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + +//Paul Buskermolen +function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean; +var + s, sUid: string; + n: integer; +begin + sUID := ''; + s := 'FETCH ' + IntToStr(MessID) + ' UID'; + Result := IMAPcommand(s) = 'OK'; + ProcessLiterals; + for n := 0 to FFullResult.Count - 1 do + begin + s := uppercase(FFullResult[n]); + if Pos('FETCH (UID', s) >= 1 then + begin + s := Separateright(s, '(UID '); + sUID := Trim(SeparateLeft(s, ')')); + end; + end; + UID := StrToIntDef(sUID, 0); +end; + +{==============================================================================} + +end. diff --git a/laz_synapse.pas b/laz_synapse.pas new file mode 100644 index 0000000..62d0f11 --- /dev/null +++ b/laz_synapse.pas @@ -0,0 +1,18 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit laz_synapse; + +interface + +uses + asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend, + imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, + pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, + synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, + synsock, tlntsend; + +implementation + +end. diff --git a/ldapsend.pas b/ldapsend.pas new file mode 100644 index 0000000..83b0177 --- /dev/null +++ b/ldapsend.pas @@ -0,0 +1,1268 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.007.001 | +|==============================================================================| +| Content: LDAP client | +|==============================================================================| +| Copyright (c)1999-2014, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2014. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(LDAP client) + +Used RFC: RFC-2251, RFC-2254, RFC-2696, RFC-2829, RFC-2830 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ldapsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, asn1util, synacode; + +const + cLDAPProtocol = '389'; + + LDAP_ASN1_BIND_REQUEST = $60; + LDAP_ASN1_BIND_RESPONSE = $61; + LDAP_ASN1_UNBIND_REQUEST = $42; + LDAP_ASN1_SEARCH_REQUEST = $63; + LDAP_ASN1_SEARCH_ENTRY = $64; + LDAP_ASN1_SEARCH_DONE = $65; + LDAP_ASN1_SEARCH_REFERENCE = $73; + LDAP_ASN1_MODIFY_REQUEST = $66; + LDAP_ASN1_MODIFY_RESPONSE = $67; + LDAP_ASN1_ADD_REQUEST = $68; + LDAP_ASN1_ADD_RESPONSE = $69; + LDAP_ASN1_DEL_REQUEST = $4A; + LDAP_ASN1_DEL_RESPONSE = $6B; + LDAP_ASN1_MODIFYDN_REQUEST = $6C; + LDAP_ASN1_MODIFYDN_RESPONSE = $6D; + LDAP_ASN1_COMPARE_REQUEST = $6E; + LDAP_ASN1_COMPARE_RESPONSE = $6F; + LDAP_ASN1_ABANDON_REQUEST = $70; + LDAP_ASN1_EXT_REQUEST = $77; + LDAP_ASN1_EXT_RESPONSE = $78; + LDAP_ASN1_CONTROLS = $A0; + + +type + + {:@abstract(LDAP attribute with list of their values) + This class holding name of LDAP attribute and list of their values. This is + descendant of TStringList class enhanced by some new properties.} + TLDAPAttribute = class(TStringList) + private + FAttributeName: AnsiString; + FIsBinary: Boolean; + protected + function Get(Index: integer): string; override; + procedure Put(Index: integer; const Value: string); override; + procedure SetAttributeName(Value: AnsiString); + public + function Add(const S: string): Integer; override; + published + {:Name of LDAP attribute.} + property AttributeName: AnsiString read FAttributeName Write SetAttributeName; + {:Return @true when attribute contains binary data.} + property IsBinary: Boolean read FIsBinary; + end; + + {:@abstract(List of @link(TLDAPAttribute)) + This object can hold list of TLDAPAttribute objects.} + TLDAPAttributeList = class(TObject) + private + FAttributeList: TList; + function GetAttribute(Index: integer): TLDAPAttribute; + public + constructor Create; + destructor Destroy; override; + {:Clear list.} + procedure Clear; + {:Return count of TLDAPAttribute objects in list.} + function Count: integer; + {:Add new TLDAPAttribute object to list.} + function Add: TLDAPAttribute; + {:Delete one TLDAPAttribute object from list.} + procedure Del(Index: integer); + {:Find and return attribute with requested name. Returns nil if not found.} + function Find(AttributeName: AnsiString): TLDAPAttribute; + {:Find and return attribute value with requested name. Returns empty string if not found.} + function Get(AttributeName: AnsiString): string; + {:List of TLDAPAttribute objects.} + property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default; + end; + + {:@abstract(LDAP result object) + This object can hold LDAP object. (their name and all their attributes with + values)} + TLDAPResult = class(TObject) + private + FObjectName: AnsiString; + FAttributes: TLDAPAttributeList; + public + constructor Create; + destructor Destroy; override; + {:Name of this LDAP object.} + property ObjectName: AnsiString read FObjectName write FObjectName; + {:Here is list of object attributes.} + property Attributes: TLDAPAttributeList read FAttributes; + end; + + {:@abstract(List of LDAP result objects) + This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)} + TLDAPResultList = class(TObject) + private + FResultList: TList; + function GetResult(Index: integer): TLDAPResult; + public + constructor Create; + destructor Destroy; override; + {:Clear all TLDAPResult objects in list.} + procedure Clear; + {:Return count of TLDAPResult objects in list.} + function Count: integer; + {:Create and add new TLDAPResult object to list.} + function Add: TLDAPResult; + {:List of TLDAPResult objects.} + property Items[Index: Integer]: TLDAPResult read GetResult; default; + end; + + {:Define possible operations for LDAP MODIFY operations.} + TLDAPModifyOp = ( + MO_Add, + MO_Delete, + MO_Replace + ); + + {:Specify possible values for search scope.} + TLDAPSearchScope = ( + SS_BaseObject, + SS_SingleLevel, + SS_WholeSubtree + ); + + {:Specify possible values about alias dereferencing.} + TLDAPSearchAliases = ( + SA_NeverDeref, + SA_InSearching, + SA_FindingBaseObj, + SA_Always + ); + + {:@abstract(Implementation of LDAP client) + (version 2 and 3) + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TLDAPSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: AnsiString; + FFullResult: AnsiString; + FAutoTLS: Boolean; + FFullSSL: Boolean; + FSeq: integer; + FResponseCode: integer; + FResponseDN: AnsiString; + FReferals: TStringList; + FVersion: integer; + FSearchScope: TLDAPSearchScope; + FSearchAliases: TLDAPSearchAliases; + FSearchSizeLimit: integer; + FSearchTimeLimit: integer; + FSearchPageSize: integer; + FSearchCookie: AnsiString; + FSearchResult: TLDAPResultList; + FExtName: AnsiString; + FExtValue: AnsiString; + function Connect: Boolean; + function BuildPacket(const Value: AnsiString): AnsiString; + function ReceiveResponse: AnsiString; + function DecodeResponse(const Value: AnsiString): AnsiString; + function LdapSasl(Value: AnsiString): AnsiString; + function TranslateFilter(Value: AnsiString): AnsiString; + function GetErrorString(Value: integer): AnsiString; + public + constructor Create; + destructor Destroy; override; + + {:Try to connect to LDAP server and start secure channel, when it is required.} + function Login: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using plaintext transport of password! It is not secure!} + function Bind: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using SASL with DIGEST-MD5 method for secure transfer of your + password.} + function BindSasl: Boolean; + + {:Close connection to LDAP server.} + function Logout: Boolean; + + {:Modify content of LDAP attribute on this object.} + function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; + + {:Add list of attributes to specified object.} + function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; + + {:Delete this LDAP object from server.} + function Delete(obj: AnsiString): Boolean; + + {:Modify object name of this LDAP object.} + function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean; + + {:Try to compare Attribute value with this LDAP object.} + function Compare(obj, AttributeValue: AnsiString): Boolean; + + {:Search LDAP base for LDAP objects by Filter.} + function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; + const Attributes: TStrings): Boolean; + + {:Call any LDAPv3 extended command.} + function Extended(const Name, Value: AnsiString): Boolean; + + {:Try to start SSL/TLS connection to LDAP server.} + function StartTLS: Boolean; + published + {:Specify version of used LDAP protocol. Default value is 3.} + property Version: integer read FVersion Write FVersion; + + {:Result code of last LDAP operation.} + property ResultCode: Integer read FResultCode; + + {:Human readable description of result code of last LDAP operation.} + property ResultString: AnsiString read FResultString; + + {:Binary string with full last response of LDAP server. This string is + encoded by ASN.1 BER encoding! You need this only for debugging.} + property FullResult: AnsiString read FFullResult; + + {:If @true, then try to start TSL mode in Login procedure.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:If @true, then use connection to LDAP server through SSL/TLS tunnel.} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Sequence number of last LDAp command. It is incremented by any LDAP command.} + property Seq: integer read FSeq; + + {:Specify what search scope is used in search command.} + property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope; + + {:Specify how to handle aliases in search command.} + property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases; + + {:Specify result size limit in search command. Value 0 means without limit.} + property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit; + + {:Specify search time limit in search command (seconds). Value 0 means + without limit.} + property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit; + + {:Specify number of results to return per search request. Value 0 means + no paging.} + property SearchPageSize: integer read FSearchPageSize Write FSearchPageSize; + + {:Cookie returned by paged search results. Use an empty string for the first + search request.} + property SearchCookie: AnsiString read FSearchCookie Write FSearchCookie; + + {:Here is result of search command.} + property SearchResult: TLDAPResultList read FSearchResult; + + {:On each LDAP operation can LDAP server return some referals URLs. Here is + their list.} + property Referals: TStringList read FReferals; + + {:When you call @link(Extended) operation, then here is result Name returned + by server.} + property ExtName: AnsiString read FExtName; + + {:When you call @link(Extended) operation, then here is result Value returned + by server.} + property ExtValue: AnsiString read FExtValue; + + {:TCP socket used by all LDAP operations.} + property Sock: TTCPBlockSocket read FSock; + end; + +{:Dump result of LDAP SEARCH into human readable form. Good for debugging.} +function LDAPResultDump(const Value: TLDAPResultList): string; + +implementation + +{==============================================================================} +function TLDAPAttribute.Add(const S: string): Integer; +begin + Result := inherited Add(''); + Put(Result,S); +end; + +function StrToHex(const s: string):string; +var + i: Integer; +begin + for i := Low(s) to High(s) do + Result := Result + Ord(s[i]).ToHexString + ' '; +end; + +function TLDAPAttribute.Get(Index: integer): string; +begin + Result := inherited Get(Index); + if FIsbinary then + Result := StrToHex(Result); +end; + +procedure TLDAPAttribute.Put(Index: integer; const Value: string); +var + s: AnsiString; +begin + s := Value; + if FIsbinary then + s := EncodeBase64(Value) + else + s :=UnquoteStr(s, '"'); + inherited Put(Index, s); +end; + +procedure TLDAPAttribute.SetAttributeName(Value: AnsiString); +begin + FAttributeName := Value; + FIsBinary := (Pos(';binary', Lowercase(value)) > 0) or (FAttributeName = 'objectGUID') or (FAttributeName = 'objectSid'); +end; + +{==============================================================================} +constructor TLDAPAttributeList.Create; +begin + inherited Create; + FAttributeList := TList.Create; +end; + +destructor TLDAPAttributeList.Destroy; +begin + Clear; + FAttributeList.Free; + inherited Destroy; +end; + +procedure TLDAPAttributeList.Clear; +var + n: integer; + x: TLDAPAttribute; +begin + for n := Count - 1 downto 0 do + begin + x := GetAttribute(n); + if Assigned(x) then + x.Free; + end; + FAttributeList.Clear; +end; + +function TLDAPAttributeList.Count: integer; +begin + Result := FAttributeList.Count; +end; + +function TLDAPAttributeList.Get(AttributeName: AnsiString): string; +var + x: TLDAPAttribute; +begin + Result := ''; + x := self.Find(AttributeName); + if x <> nil then + if x.Count > 0 then + Result := x[0]; +end; + +function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute; +begin + Result := nil; + if Index < Count then + Result := TLDAPAttribute(FAttributeList[Index]); +end; + +function TLDAPAttributeList.Add: TLDAPAttribute; +begin + Result := TLDAPAttribute.Create; + FAttributeList.Add(Result); +end; + +procedure TLDAPAttributeList.Del(Index: integer); +var + x: TLDAPAttribute; +begin + x := GetAttribute(Index); + if Assigned(x) then + x.free; + FAttributeList.Delete(Index); +end; + +function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute; +var + n: integer; + x: TLDAPAttribute; +begin + Result := nil; + AttributeName := lowercase(AttributeName); + for n := 0 to Count - 1 do + begin + x := GetAttribute(n); + if Assigned(x) then + if lowercase(x.AttributeName) = Attributename then + begin + result := x; + break; + end; + end; +end; + +{==============================================================================} +constructor TLDAPResult.Create; +begin + inherited Create; + FAttributes := TLDAPAttributeList.Create; +end; + +destructor TLDAPResult.Destroy; +begin + FAttributes.Free; + inherited Destroy; +end; + +{==============================================================================} +constructor TLDAPResultList.Create; +begin + inherited Create; + FResultList := TList.Create; +end; + +destructor TLDAPResultList.Destroy; +begin + Clear; + FResultList.Free; + inherited Destroy; +end; + +procedure TLDAPResultList.Clear; +var + n: integer; + x: TLDAPResult; +begin + for n := Count - 1 downto 0 do + begin + x := GetResult(n); + if Assigned(x) then + x.Free; + end; + FResultList.Clear; +end; + +function TLDAPResultList.Count: integer; +begin + Result := FResultList.Count; +end; + +function TLDAPResultList.GetResult(Index: integer): TLDAPResult; +begin + Result := nil; + if Index < Count then + Result := TLDAPResult(FResultList[Index]); +end; + +function TLDAPResultList.Add: TLDAPResult; +begin + Result := TLDAPResult.Create; + FResultList.Add(Result); +end; + +{==============================================================================} +constructor TLDAPSend.Create; +begin + inherited Create; + FReferals := TStringList.Create; + FFullResult := ''; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 60000; + FTargetPort := cLDAPProtocol; + FAutoTLS := False; + FFullSSL := False; + FSeq := 0; + FVersion := 3; + FSearchScope := SS_WholeSubtree; + FSearchAliases := SA_Always; + FSearchSizeLimit := 0; + FSearchTimeLimit := 0; + FSearchPageSize := 0; + FSearchCookie := ''; + FSearchResult := TLDAPResultList.Create; +end; + +destructor TLDAPSend.Destroy; +begin + FSock.Free; + FSearchResult.Free; + FReferals.Free; + inherited Destroy; +end; + +function TLDAPSend.GetErrorString(Value: integer): AnsiString; +begin + case Value of + 0: + Result := 'Success'; + 1: + Result := 'Operations error'; + 2: + Result := 'Protocol error'; + 3: + Result := 'Time limit Exceeded'; + 4: + Result := 'Size limit Exceeded'; + 5: + Result := 'Compare FALSE'; + 6: + Result := 'Compare TRUE'; + 7: + Result := 'Auth method not supported'; + 8: + Result := 'Strong auth required'; + 9: + Result := '-- reserved --'; + 10: + Result := 'Referal'; + 11: + Result := 'Admin limit exceeded'; + 12: + Result := 'Unavailable critical extension'; + 13: + Result := 'Confidentality required'; + 14: + Result := 'Sasl bind in progress'; + 16: + Result := 'No such attribute'; + 17: + Result := 'Undefined attribute type'; + 18: + Result := 'Inappropriate matching'; + 19: + Result := 'Constraint violation'; + 20: + Result := 'Attribute or value exists'; + 21: + Result := 'Invalid attribute syntax'; + 32: + Result := 'No such object'; + 33: + Result := 'Alias problem'; + 34: + Result := 'Invalid DN syntax'; + 36: + Result := 'Alias dereferencing problem'; + 48: + Result := 'Inappropriate authentication'; + 49: + Result := 'Invalid credentials'; + 50: + Result := 'Insufficient access rights'; + 51: + Result := 'Busy'; + 52: + Result := 'Unavailable'; + 53: + Result := 'Unwilling to perform'; + 54: + Result := 'Loop detect'; + 64: + Result := 'Naming violation'; + 65: + Result := 'Object class violation'; + 66: + Result := 'Not allowed on non leaf'; + 67: + Result := 'Not allowed on RDN'; + 68: + Result := 'Entry already exists'; + 69: + Result := 'Object class mods prohibited'; + 71: + Result := 'Affects multiple DSAs'; + 80: + Result := 'Other'; + else + Result := '--unknown--'; + end; +end; + +function TLDAPSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSeq := 0; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString; +begin + Inc(FSeq); + Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ); +end; + +function TLDAPSend.ReceiveResponse: AnsiString; +var + x: Byte; + i,j: integer; +begin + Result := ''; + FFullResult := ''; + x := FSock.RecvByte(FTimeout); + if x <> ASN1_SEQ then + Exit; + Result := AnsiChar(x); + x := FSock.RecvByte(FTimeout); + Result := Result + AnsiChar(x); + if x < $80 then + i := 0 + else + i := x and $7F; + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + //get length of LDAP packet + j := 2; + i := ASNDecLen(j, Result); + //retreive rest of LDAP packet + if i > 0 then + Result := Result + FSock.RecvBufferStr(i, Ftimeout); + if FSock.LastError <> 0 then + begin + Result := ''; + Exit; + end; + FFullResult := Result; +end; + +function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString; +var + i, x: integer; + Svt: Integer; + s, t: AnsiString; +begin + Result := ''; + FResultCode := -1; + FResultstring := ''; + FResponseCode := -1; + FResponseDN := ''; + FReferals.Clear; + i := 1; + ASNItem(i, Value, Svt); + x := StrToIntDef(ASNItem(i, Value, Svt), 0); + if (svt <> ASN1_INT) or (x <> FSeq) then + Exit; + s := ASNItem(i, Value, Svt); + FResponseCode := svt; + if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE, + LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE, + LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE, + LDAP_ASN1_EXT_RESPONSE] then + begin + FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1); + FResponseDN := ASNItem(i, Value, Svt); + FResultString := ASNItem(i, Value, Svt); + if FResultString = '' then + FResultString := GetErrorString(FResultCode); + if FResultCode = 10 then + begin + s := ASNItem(i, Value, Svt); + if svt = $A3 then + begin + x := 1; + while x < Length(s) do + begin + t := ASNItem(x, s, Svt); + FReferals.Add(t); + end; + end; + end; + end; + Result := Copy(Value, i, Length(Value) - i + 1); +end; + +function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString; +var + nonce, cnonce, nc, realm, qop, uri, response: AnsiString; + s: AnsiString; + a1, a2: AnsiString; + l: TStringList; + n: integer; +begin + l := TStringList.Create; + try + nonce := ''; + realm := ''; + l.CommaText := Value; + n := IndexByBegin('nonce=', l); + if n >= 0 then + nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"'); + n := IndexByBegin('realm=', l); + if n >= 0 then + realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"'); + cnonce := IntToHex(GetTick, 8); + nc := '00000001'; + qop := 'auth'; + uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP); + a1 := md5(FUsername + ':' + realm + ':' + FPassword) + + ':' + nonce + ':' + cnonce; + a2 := 'AUTHENTICATE:' + uri; + s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':' + + qop +':'+strtohex(md5(a2)); + response := strtohex(md5(s)); + + Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="'; + Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop='; + Result := Result + qop + ',digest-uri="' + uri + '",response=' + response; + finally + l.Free; + end; +end; + +function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString; +var + x: integer; + s, t, l: AnsiString; + r: string; + c: Ansichar; + attr, rule: AnsiString; + dn: Boolean; +begin + Result := ''; + if Value = '' then + Exit; + s := Value; + if Value[1] = '(' then + begin + x := RPos(')', Value); + s := Copy(Value, 2, x - 2); + end; + if s = '' then + Exit; + case s[1] of + '!': + // NOT rule (recursive call) + begin + Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2); + end; + '&': + // AND rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := Trim(SeparateRight(s, t)); + if s <> '' then + if s[1] = ')' then + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A0); + end; + '|': + // OR rule (recursive call) + begin + repeat + t := GetBetween('(', ')', s); + s := Trim(SeparateRight(s, t)); + if s <> '' then + if s[1] = ')' then + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); + Result := Result + TranslateFilter(t); + until s = ''; + Result := ASNOBject(Result, $A1); + end; + else + begin + l := Trim(SeparateLeft(s, '=')); + r := Trim(SeparateRight(s, '=')); + if l <> '' then + begin + c := l[Length(l)]; + case c of + ':': + // Extensible match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + dn := False; + attr := ''; + rule := ''; + if Pos(':dn', l) > 0 then + begin + dn := True; + l := ReplaceString(l, ':dn', ''); + end; + attr := Trim(SeparateLeft(l, ':')); + rule := Trim(SeparateRight(l, ':')); + if rule = l then + rule := ''; + if rule <> '' then + Result := ASNObject(rule, $81); + if attr <> '' then + Result := Result + ASNObject(attr, $82); + Result := Result + ASNObject(DecodeTriplet(r, '\'), $83); + if dn then + Result := Result + ASNObject(AsnEncInt($ff), $84) + else + Result := Result + ASNObject(AsnEncInt(0), $84); + Result := ASNOBject(Result, $a9); + end; + '~': + // Approx match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a8); + end; + '>': + // Greater or equal match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a5); + end; + '<': + // Less or equal match + begin + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a6); + end; + else + // present + if r = '*' then + Result := ASNOBject(l, $87) + else + if Pos('*', r) > 0 then + // substrings + begin + s := Fetch(r, '*'); + if s <> '' then + Result := ASNOBject(DecodeTriplet(s, '\'), $80); + while r <> '' do + begin + if Pos('*', r) <= 0 then + break; + s := Fetch(r, '*'); + Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81); + end; + if r <> '' then + Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82); + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(Result, ASN1_SEQ); + Result := ASNOBject(Result, $a4); + end + else + begin + // Equality match + Result := ASNOBject(l, ASN1_OCTSTR) + + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); + Result := ASNOBject(Result, $a3); + end; + end; + end; + end; + end; +end; + +function TLDAPSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; + if FAutoTLS then + Result := StartTLS; +end; + +function TLDAPSend.Bind: Boolean; +var + s: AnsiString; +begin + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject(FUsername, ASN1_OCTSTR) + + ASNObject(FPassword, $80); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.BindSasl: Boolean; +var + s, t: AnsiString; + x, xt: integer; + digreq: AnsiString; +begin + Result := False; + if FPassword = '' then + Result := Bind + else + begin + digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_OCTSTR) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3); + digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + t := DecodeResponse(s); + if FResultCode = 14 then + begin + s := t; + x := 1; + t := ASNItem(x, s, xt); + s := ASNObject(ASNEncInt(FVersion), ASN1_INT) + + ASNObject('', ASN1_OCTSTR) + + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR) + + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3); + s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + if FResultCode = 14 then + begin + Fsock.SendString(BuildPacket(digreq)); + s := ReceiveResponse; + DecodeResponse(s); + end; + Result := FResultCode = 0; + end; + end; +end; + +function TLDAPSend.Logout: Boolean; +begin + Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); + FSock.CloseSocket; + Result := True; +end; + +function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; +var + s: AnsiString; + n: integer; +begin + s := ''; + for n := 0 to Value.Count -1 do + s := s + ASNObject(Value[n], ASN1_OCTSTR); + s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF); + s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, ASN1_SEQ); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; +var + s, t: AnsiString; + n, m: integer; +begin + s := ''; + for n := 0 to Value.Count - 1 do + begin + t := ''; + for m := 0 to Value[n].Count - 1 do + t := t + ASNObject(Value[n][m], ASN1_OCTSTR); + t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR) + + ASNObject(t, ASN1_SETOF); + s := s + ASNObject(t, ASN1_SEQ); + end; + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_ADD_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Delete(obj: AnsiString): Boolean; +var + s: AnsiString; +begin + s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean; +var + s: AnsiString; +begin + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR); + if DeleteOldRDN then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if newSuperior <> '' then + s := s + ASNObject(newSuperior, $80); + s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean; +var + s: AnsiString; +begin + s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR) + + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR); + s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + DecodeResponse(s); + Result := FResultCode = 0; +end; + +function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; + const Attributes: TStrings): Boolean; +var + s, t, u, c: AnsiString; + n, i, x: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + FSearchResult.Clear; + FReferals.Clear; + s := ASNObject(obj, ASN1_OCTSTR); + s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM); + s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT); + s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT); + if TypesOnly then + s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) + else + s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); + if Filter = '' then + Filter := '(objectclass=*)'; + t := TranslateFilter(Filter); + if t = '' then + s := s + ASNObject('', ASN1_NULL) + else + s := s + t; + t := ''; + for n := 0 to Attributes.Count - 1 do + t := t + ASNObject(Attributes[n], ASN1_OCTSTR); + s := s + ASNObject(t, ASN1_SEQ); + s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST); + if FSearchPageSize > 0 then + begin + c := ASNObject('1.2.840.113556.1.4.319', ASN1_OCTSTR); // controlType: pagedResultsControl + c := c + ASNObject(ASNEncInt(0), ASN1_BOOL); // criticality: FALSE + t := ASNObject(ASNEncInt(FSearchPageSize), ASN1_INT); // page size + t := t + ASNObject(FSearchCookie, ASN1_OCTSTR); // search cookie + t := ASNObject(t, ASN1_SEQ); // wrap with SEQUENCE + c := c + ASNObject(t, ASN1_OCTSTR); // add searchControlValue as OCTET STRING + c := ASNObject(c, ASN1_SEQ); // wrap with SEQUENCE + s := s + ASNObject(c, LDAP_ASN1_CONTROLS); // append Controls to SearchRequest + end; + Fsock.SendString(BuildPacket(s)); + repeat + s := ReceiveResponse; + t := DecodeResponse(s); + if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then + begin + //dekoduj zaznam + r := FSearchResult.Add; + n := 1; + r.ObjectName := ASNItem(n, t, x); + ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + while n < Length(t) do + begin + s := ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + i := n + Length(s); + a := r.Attributes.Add; + u := ASNItem(n, t, x); + a.AttributeName := u; + ASNItem(n, t, x); + if x = ASN1_SETOF then + while n < i do + begin + u := ASNItem(n, t, x); + a.Add(u); + end; + end; + end; + end; + end; + if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then + begin + n := 1; + while n < Length(t) do + FReferals.Add(ASNItem(n, t, x)); + end; + until FResponseCode = LDAP_ASN1_SEARCH_DONE; + n := 1; + ASNItem(n, t, x); + if x = LDAP_ASN1_CONTROLS then + begin + ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + s := ASNItem(n, t, x); + if s = '1.2.840.113556.1.4.319' then + begin + s := ASNItem(n, t, x); // searchControlValue + n := 1; + ASNItem(n, s, x); + if x = ASN1_SEQ then + begin + ASNItem(n, s, x); // total number of result records, if known, otherwise 0 + FSearchCookie := ASNItem(n, s, x); // active search cookie, empty when done + end; + end; + end; + end; + Result := FResultCode = 0; +end; + +function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean; +var + s, t: AnsiString; + x, xt: integer; +begin + s := ASNObject(Name, $80); + if Value <> '' then + s := s + ASNObject(Value, $81); + s := ASNObject(s, LDAP_ASN1_EXT_REQUEST); + Fsock.SendString(BuildPacket(s)); + s := ReceiveResponse; + t := DecodeResponse(s); + Result := FResultCode = 0; + if Result then + begin + x := 1; + FExtName := ASNItem(x, t, xt); + FExtValue := ASNItem(x, t, xt); + end; +end; + + +function TLDAPSend.StartTLS: Boolean; +begin + Result := Extended('1.3.6.1.4.1.1466.20037', ''); + if Result then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +{==============================================================================} +function LDAPResultDump(const Value: TLDAPResultList): string; +var + n, m, o: integer; + r: TLDAPResult; + a: TLDAPAttribute; +begin + Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF; + for n := 0 to Value.Count - 1 do + begin + Result := Result + 'Result: ' + IntToStr(n) + CRLF; + r := Value[n]; + Result := Result + ' Object: ' + r.ObjectName + CRLF; + for m := 0 to r.Attributes.Count - 1 do + begin + a := r.Attributes[m]; + Result := Result + ' Attribute: ' + a.AttributeName + CRLF; + for o := 0 to a.Count - 1 do + Result := Result + ' ' + a[o] + CRLF; + end; + end; +end; + +end. diff --git a/mimeinln.pas b/mimeinln.pas new file mode 100644 index 0000000..a6fb506 --- /dev/null +++ b/mimeinln.pas @@ -0,0 +1,263 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.011 | +|==============================================================================| +| Content: Inline MIME support procedures and functions | +|==============================================================================| +| Copyright (c)1999-2006, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Utilities for inline MIME) +Support for Inline MIME encoding and decoding. + +Used RFC: RFC-2047, RFC-2231 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit mimeinln; + +interface + +uses + SysUtils, Classes, + synachar, synacode, synautil; + +{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} +function InlineDecode(const Value: string; CP: TMimeChar): string; + +{:Encodes string to MIME inline encoding. The source characterset is "CP", and + the target charset is "MimeP".} +function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; + +{:Returns @true, if "Value" contains characters needed for inline coding.} +function NeedInline(const Value: AnsiString): boolean; + +{:Inline mime encoding similar to @link(InlineEncode), but you can specify + source charset, and the target characterset is automatically assigned.} +function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; + +{:Inline MIME encoding similar to @link(InlineEncode), but the source charset + is automatically set to the system default charset, and the target charset is + automatically assigned from set of allowed encoding for MIME.} +function InlineCode(const Value: string): string; + +{:Converts e-mail address to canonical mime form. You can specify source charset.} +function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; + +{:Converts e-mail address to canonical mime form. Source charser it system + default charset.} +function InlineEmail(const Value: string): string; + +implementation + +{==============================================================================} + +function InlineDecode(const Value: string; CP: TMimeChar): string; +var + s, su, v: string; + x, y, z, n: Integer; + ichar: TMimeChar; + c: Char; + + function SearchEndInline(const Value: string; be: Integer): Integer; + var + n, q: Integer; + begin + q := 0; + Result := 0; + for n := be + 2 to Length(Value) - 1 do + if Value[n] = '?' then + begin + Inc(q); + if (q > 2) and (Value[n + 1] = '=') then + begin + Result := n; + Break; + end; + end; + end; + +begin + Result := ''; + v := Value; + x := Pos('=?', v); + y := SearchEndInline(v, x); + //fix for broken coding with begin, but not with end. + if (x > 0) and (y <= 0) then + y := Length(Result); + while (y > x) and (x > 0) do + begin + s := Copy(v, 1, x - 1); + if Trim(s) <> '' then + Result := Result + s; + s := Copy(v, x, y - x + 2); + Delete(v, 1, y + 1); + su := Copy(s, 3, Length(s) - 4); + z := Pos('?', su); + if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then + begin + ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); + c := UpperCase(su)[z + 1]; + su := Copy(su, z + 3, Length(su) - z - 2); + if c = 'B' then + begin + s := DecodeBase64(su); + s := CharsetConversion(s, ichar, CP); + end; + if c = 'Q' then + begin + s := ''; + for n := 1 to Length(su) do + if su[n] = '_' then + s := s + ' ' + else + s := s + su[n]; + s := DecodeQuotedPrintable(s); + s := CharsetConversion(s, ichar, CP); + end; + end; + Result := Result + s; + x := Pos('=?', v); + y := SearchEndInline(v, x); + end; + Result := Result + v; +end; + +{==============================================================================} + +function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; +var + s, s1, e: string; + n: Integer; +begin + s := CharsetConversion(Value, CP, MimeP); + s := EncodeSafeQuotedPrintable(s); + e := GetIdFromCP(MimeP); + s1 := ''; + Result := ''; + for n := 1 to Length(s) do + if s[n] = ' ' then + begin +// s1 := s1 + '=20'; + s1 := s1 + '_'; + if Length(s1) > 32 then + begin + if Result <> '' then + Result := Result + ' '; + Result := Result + '=?' + e + '?Q?' + s1 + '?='; + s1 := ''; + end; + end + else + s1 := s1 + s[n]; + if s1 <> '' then + begin + if Result <> '' then + Result := Result + ' '; + Result := Result + '=?' + e + '?Q?' + s1 + '?='; + end; +end; + +{==============================================================================} + +function NeedInline(const Value: AnsiString): boolean; +var + n: Integer; +begin + Result := False; + for n := 1 to Length(Value) do + if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} + +function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; +var + c: TMimeChar; +begin + if NeedInline(Value) then + begin + c := IdealCharsetCoding(Value, FromCP, IdealCharsets); + Result := InlineEncode(Value, FromCP, c); + end + else + Result := Value; +end; + +{==============================================================================} + +function InlineCode(const Value: string): string; +begin + Result := InlineCodeEx(Value, GetCurCP); +end; + +{==============================================================================} + +function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; +var + sd, se: string; +begin + sd := GetEmailDesc(Value); + se := GetEmailAddr(Value); + if sd = '' then + Result := se + else + Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; +end; + +{==============================================================================} + +function InlineEmail(const Value: string): string; +begin + Result := InlineEmailEx(Value, GetCurCP); +end; + +end. diff --git a/mimemess.pas b/mimemess.pas new file mode 100644 index 0000000..9f9a9c7 --- /dev/null +++ b/mimemess.pas @@ -0,0 +1,851 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.006.000 | +|==============================================================================| +| Content: MIME message object | +|==============================================================================| +| Copyright (c)1999-2012, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM From distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(MIME message handling) +Classes for easy handling with e-mail message. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$M+} + +unit mimemess; + +interface + +uses + Classes, SysUtils, + mimepart, synachar, synautil, mimeinln; + +type + + {:Possible values for message priority} + TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high); + + {:@abstract(Object for basic e-mail header fields.)} + TMessHeader = class(TObject) + private + FFrom: string; + FToList: TStringList; + FCCList: TStringList; + FSubject: string; + FOrganization: string; + FCustomHeaders: TStringList; + FDate: TDateTime; + FXMailer: string; + FCharsetCode: TMimeChar; + FReplyTo: string; + FMessageID: string; + FPriority: TMessPriority; + Fpri: TMessPriority; + Fxpri: TMessPriority; + Fxmspri: TMessPriority; + protected + function ParsePriority(value: string): TMessPriority; + function DecodeHeader(value: string): boolean; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + + {:Clears all data fields.} + procedure Clear; virtual; + + {Add headers from from this object to Value.} + procedure EncodeHeaders(const Value: TStrings); virtual; + + {:Parse header from Value to this object.} + procedure DecodeHeaders(const Value: TStrings); + + {:Try find specific header in CustomHeader. Search is case insensitive. + This is good for reading any non-parsed header.} + function FindHeader(Value: string): string; + + {:Try find specific headers in CustomHeader. This metod is for repeatly used + headers like 'received' header, etc. Search is case insensitive. + This is good for reading ano non-parsed header.} + procedure FindHeaderList(Value: string; const HeaderList: TStrings); + published + {:Sender of message.} + property From: string read FFrom Write FFrom; + + {:Stringlist with receivers of message. (one per line)} + property ToList: TStringList read FToList; + + {:Stringlist with Carbon Copy receivers of message. (one per line)} + property CCList: TStringList read FCCList; + + {:Subject of message.} + property Subject: string read FSubject Write FSubject; + + {:Organization string.} + property Organization: string read FOrganization Write FOrganization; + + {:After decoding contains all headers lines witch not have parsed to any + other structures in this object. It mean: this conatins all other headers + except: + + X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION, + CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID, + CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY, + X-PRIORITY, PRIORITY + + When you encode headers, all this lines is added as headers. Be carefull + for duplicites!} + property CustomHeaders: TStringList read FCustomHeaders; + + {:Date and time of message.} + property Date: TDateTime read FDate Write FDate; + + {:Mailer identification.} + property XMailer: string read FXMailer Write FXMailer; + + {:Address for replies} + property ReplyTo: string read FReplyTo Write FReplyTo; + + {:message indetifier} + property MessageID: string read FMessageID Write FMessageID; + + {:message priority} + property Priority: TMessPriority read FPriority Write FPriority; + + {:Specify base charset. By default is used system charset.} + property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; + end; + + TMessHeaderClass = class of TMessHeader; + + {:@abstract(Object for handling of e-mail message.)} + TMimeMess = class(TObject) + private + FMessagePart: TMimePart; + FLines: TStringList; + FHeader: TMessHeader; + public + constructor Create; + {:create this object and assign your own descendant of @link(TMessHeader) + object to @link(header) property. So, you can create your own message + headers parser and use it by this object.} + constructor CreateAltHeaders(HeadClass: TMessHeaderClass); + destructor Destroy; override; + + {:Reset component to default state.} + procedure Clear; virtual; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then one subpart, + you must have PartParent of multipart type!} + function AddPart(const PartParent: TMimePart): TMimePart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + This part is marked as multipart with secondary MIME type specified by + MultipartType parameter. (typical value is 'mixed') + + This part can be used as PartParent for another parts (include next + multipart). If you need only one part, then you not need Multipart part.} + function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to text part and set all necessary + properties. Content of part is readed from value stringlist.} + function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to text part and set all necessary + properties. Content of part is readed from value stringlist. You can select + your charset and your encoding type. If Raw is @true, then it not doing + charset conversion!} + function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; + PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to text part to HTML type and set all + necessary properties. Content of HTML part is readed from Value stringlist.} + function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartText), but content is readed from file} + function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartHTML), but content is readed from file} + function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, + you must have PartParent of multipart type! + + After creation of part set type to binary and set all necessary properties. + MIME primary and secondary types defined automaticly by filename extension. + Content of binary part is readed from Stream. This binary part is encoded + as file attachment.} + function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartBinary), but content is readed from file} + function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to binary and set all necessary properties. + MIME primary and secondary types defined automaticly by filename extension. + Content of binary part is readed from Stream. + + This binary part is encoded as inline data with given Conten ID (cid). + Content ID can be used as reference ID in HTML source in HTML part.} + function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartHTMLBinary), but content is readed from file} + function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to message and set all necessary properties. + MIME primary and secondary types are setted to 'message/rfc822'. + Content of raw RFC-822 message is readed from Stream.} + function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartMess), but content is readed from file} + function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Compose message from @link(MessagePart) to @link(Lines). Headers from + @link(Header) object is added also.} + procedure EncodeMessage; virtual; + + {:Decode message from @link(Lines) to @link(MessagePart). Massage headers + are parsed into @link(Header) object.} + procedure DecodeMessage; virtual; + + {pf} + {: HTTP message is received by @link(THTTPSend) component in two parts: + headers are stored in @link(THTTPSend.Headers) and a body in memory stream + @link(THTTPSend.Document). + + On the top of it, HTTP connections are always 8-bit, hence data are + transferred in native format i.e. no transfer encoding is applied. + + This method operates the similiar way and produces the same + result as @link(DecodeMessage). + } + procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); + {/pf} + published + {:@link(TMimePart) object with decoded MIME message. This object can handle + any number of nested @link(TMimePart) objects itself. It is used for handle + any tree of MIME subparts.} + property MessagePart: TMimePart read FMessagePart; + + {:Raw MIME encoded message.} + property Lines: TStringList read FLines; + + {:Object for e-mail header fields. This object is created automaticly. + Do not free this object!} + property Header: TMessHeader read FHeader; + end; + +implementation + +{==============================================================================} + +constructor TMessHeader.Create; +begin + inherited Create; + FToList := TStringList.Create; + FCCList := TStringList.Create; + FCustomHeaders := TStringList.Create; + FCharsetCode := GetCurCP; +end; + +destructor TMessHeader.Destroy; +begin + FCustomHeaders.Free; + FCCList.Free; + FToList.Free; + inherited Destroy; +end; + +{==============================================================================} + +procedure TMessHeader.Clear; +begin + FFrom := ''; + FToList.Clear; + FCCList.Clear; + FSubject := ''; + FOrganization := ''; + FCustomHeaders.Clear; + FDate := 0; + FXMailer := ''; + FReplyTo := ''; + FMessageID := ''; + FPriority := MP_unknown; +end; + +procedure TMessHeader.EncodeHeaders(const Value: TStrings); +var + n: Integer; + s: string; +begin + if FDate = 0 then + FDate := Now; + for n := FCustomHeaders.Count - 1 downto 0 do + if FCustomHeaders[n] <> '' then + Value.Insert(0, FCustomHeaders[n]); + if FPriority <> MP_unknown then + case FPriority of + MP_high: + begin + Value.Insert(0, 'X-MSMAIL-Priority: High'); + Value.Insert(0, 'X-Priority: 1'); + Value.Insert(0, 'Priority: urgent'); + end; + MP_low: + begin + Value.Insert(0, 'X-MSMAIL-Priority: low'); + Value.Insert(0, 'X-Priority: 5'); + Value.Insert(0, 'Priority: non-urgent'); + end; + end; + if FReplyTo <> '' then + Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo)); + if FMessageID <> '' then + Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>'); + if FXMailer = '' then + Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer') + else + Value.Insert(0, 'X-mailer: ' + FXMailer); + Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); + if FOrganization <> '' then + Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode)); + s := ''; + for n := 0 to FCCList.Count - 1 do + if s = '' then + s := InlineEmailEx(FCCList[n], FCharsetCode) + else + s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode); + if s <> '' then + Value.Insert(0, 'CC: ' + s); + Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); + if FSubject <> '' then + Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode)); + s := ''; + for n := 0 to FToList.Count - 1 do + if s = '' then + s := InlineEmailEx(FToList[n], FCharsetCode) + else + s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode); + if s <> '' then + Value.Insert(0, 'To: ' + s); + Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); +end; + +function TMessHeader.ParsePriority(value: string): TMessPriority; +var + s: string; + x: integer; +begin + Result := MP_unknown; + s := Trim(separateright(value, ':')); + s := Separateleft(s, ' '); + x := StrToIntDef(s, -1); + if x >= 0 then + case x of + 1, 2: + Result := MP_High; + 3: + Result := MP_Normal; + 4, 5: + Result := MP_Low; + end + else + begin + s := lowercase(s); + if (s = 'urgent') or (s = 'high') or (s = 'highest') then + Result := MP_High; + if (s = 'normal') or (s = 'medium') then + Result := MP_Normal; + if (s = 'low') or (s = 'lowest') + or (s = 'no-priority') or (s = 'non-urgent') then + Result := MP_Low; + end; +end; + +function TMessHeader.DecodeHeader(value: string): boolean; +var + s, t: string; + cp: TMimeChar; +begin + Result := True; + cp := FCharsetCode; + s := uppercase(value); + if Pos('X-MAILER:', s) = 1 then + begin + FXMailer := Trim(SeparateRight(Value, ':')); + Exit; + end; + if Pos('FROM:', s) = 1 then + begin + FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('SUBJECT:', s) = 1 then + begin + FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('ORGANIZATION:', s) = 1 then + begin + FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('TO:', s) = 1 then + begin + s := Trim(SeparateRight(Value, ':')); + repeat + t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); + if t <> '' then + FToList.Add(t); + until s = ''; + Exit; + end; + if Pos('CC:', s) = 1 then + begin + s := Trim(SeparateRight(Value, ':')); + repeat + t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); + if t <> '' then + FCCList.Add(t); + until s = ''; + Exit; + end; + if Pos('DATE:', s) = 1 then + begin + FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':'))); + Exit; + end; + if Pos('REPLY-TO:', s) = 1 then + begin + FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('MESSAGE-ID:', s) = 1 then + begin + FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':'))); + Exit; + end; + if Pos('PRIORITY:', s) = 1 then + begin + FPri := ParsePriority(value); + Exit; + end; + if Pos('X-PRIORITY:', s) = 1 then + begin + FXPri := ParsePriority(value); + Exit; + end; + if Pos('X-MSMAIL-PRIORITY:', s) = 1 then + begin + FXmsPri := ParsePriority(value); + Exit; + end; + if Pos('MIME-VERSION:', s) = 1 then + Exit; + if Pos('CONTENT-TYPE:', s) = 1 then + Exit; + if Pos('CONTENT-DESCRIPTION:', s) = 1 then + Exit; + if Pos('CONTENT-DISPOSITION:', s) = 1 then + Exit; + if Pos('CONTENT-ID:', s) = 1 then + Exit; + if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then + Exit; + Result := False; +end; + +procedure TMessHeader.DecodeHeaders(const Value: TStrings); +var + s: string; + x: Integer; +begin + Clear; + Fpri := MP_unknown; + Fxpri := MP_unknown; + Fxmspri := MP_unknown; + x := 0; + while Value.Count > x do + begin + s := NormalizeHeader(Value, x); + if s = '' then + Break; + if not DecodeHeader(s) then + FCustomHeaders.Add(s); + end; + if Fpri <> MP_unknown then + FPriority := Fpri + else + if Fxpri <> MP_unknown then + FPriority := Fxpri + else + if Fxmspri <> MP_unknown then + FPriority := Fxmspri +end; + +function TMessHeader.FindHeader(Value: string): string; +var + n: integer; +begin + Result := ''; + for n := 0 to FCustomHeaders.Count - 1 do + if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then + begin + Result := Trim(SeparateRight(FCustomHeaders[n], ':')); + break; + end; +end; + +procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings); +var + n: integer; +begin + HeaderList.Clear; + for n := 0 to FCustomHeaders.Count - 1 do + if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then + begin + HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':'))); + end; +end; + +{==============================================================================} + +constructor TMimeMess.Create; +begin + CreateAltHeaders(TMessHeader); +end; + +constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass); +begin + inherited Create; + FMessagePart := TMimePart.Create; + FLines := TStringList.Create; + FHeader := HeadClass.Create; +end; + +destructor TMimeMess.Destroy; +begin + FMessagePart.Free; + FHeader.Free; + FLines.Free; + inherited Destroy; +end; + +{==============================================================================} + +procedure TMimeMess.Clear; +begin + FMessagePart.Clear; + FLines.Clear; + FHeader.Clear; +end; + +{==============================================================================} + +function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart; +begin + if PartParent = nil then + Result := FMessagePart + else + Result := PartParent.AddSubPart; + Result.Clear; +end; + +{==============================================================================} + +function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; +begin + Result := AddPart(PartParent); + with Result do + begin + Primary := 'Multipart'; + Secondary := MultipartType; + Description := 'Multipart message'; + Boundary := GenerateBoundary; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + with Result do + begin + Value.SaveToStream(DecodedLines); + Primary := 'text'; + Secondary := 'plain'; + Description := 'Message text'; + Disposition := 'inline'; + CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets); + EncodingCode := ME_QUOTED_PRINTABLE; + EncodePart; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; + PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart; +begin + Result := AddPart(PartParent); + with Result do + begin + Value.SaveToStream(DecodedLines); + Primary := 'text'; + Secondary := 'plain'; + Description := 'Message text'; + Disposition := 'inline'; + CharsetCode := PartCharset; + EncodingCode := PartEncoding; + ConvertCharset := not Raw; + EncodePart; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + with Result do + begin + Value.SaveToStream(DecodedLines); + Primary := 'text'; + Secondary := 'html'; + Description := 'HTML text'; + Disposition := 'inline'; + CharsetCode := UTF_8; + EncodingCode := ME_QUOTED_PRINTABLE; + EncodePart; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; +var + tmp: TStrings; +begin + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartText(tmp, PartParent); + Finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; +var + tmp: TStrings; +begin + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartHTML(tmp, PartParent); + Finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + Result.DecodedLines.LoadFromStream(Stream); + Result.MimeTypeFromExt(FileName); + Result.Description := 'Attached file: ' + FileName; + Result.Disposition := 'attachment'; + Result.FileName := FileName; + Result.EncodingCode := ME_BASE64; + Result.EncodePart; + Result.EncodePartHeader; +end; + +function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; +var + tmp: TMemoryStream; +begin + tmp := TMemoryStream.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent); + finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; +begin + Result := AddPart(PartParent); + Result.DecodedLines.LoadFromStream(Stream); + Result.MimeTypeFromExt(FileName); + Result.Description := 'Included file: ' + FileName; + Result.Disposition := 'inline'; + Result.ContentID := Cid; + Result.FileName := FileName; + Result.EncodingCode := ME_BASE64; + Result.EncodePart; + Result.EncodePartHeader; +end; + +function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; +var + tmp: TMemoryStream; +begin + tmp := TMemoryStream.Create; + try + tmp.LoadFromFile(FileName); + Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent); + finally + tmp.Free; + end; +end; + +function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; +var + part: Tmimepart; +begin + Result := AddPart(PartParent); + part := AddPart(result); + part.lines.addstrings(Value); + part.DecomposeParts; + with Result do + begin + Primary := 'message'; + Secondary := 'rfc822'; + Description := 'E-mail Message'; + EncodePart; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; +var + tmp: TStrings; +begin + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartMess(tmp, PartParent); + Finally + tmp.Free; + end; +end; + +{==============================================================================} + +procedure TMimeMess.EncodeMessage; +var + l: TStringList; + x: integer; +begin + //merge headers from THeaders and header field from MessagePart + l := TStringList.Create; + try + FHeader.EncodeHeaders(l); + x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-ID', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers); + if x >= 0 then + l.add(FMessagePart.Headers[x]); + FMessagePart.Headers.Assign(l); + finally + l.Free; + end; + FMessagePart.ComposeParts; + FLines.Assign(FMessagePart.Lines); +end; + +{==============================================================================} + +procedure TMimeMess.DecodeMessage; +begin + FHeader.Clear; + FHeader.DecodeHeaders(FLines); + FMessagePart.Lines.Assign(FLines); + FMessagePart.DecomposeParts; +end; + +{pf} +procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); +begin + FHeader.Clear; + FLines.Clear; + FLines.Assign(AHeader); + FHeader.DecodeHeaders(FLines); + FMessagePart.DecomposePartsBinary(AHeader,PChar(AData.Memory),PChar(AData.Memory)+AData.Size); +end; +{/pf} + +end. diff --git a/mimepart.pas b/mimepart.pas new file mode 100644 index 0000000..e1ff0c1 --- /dev/null +++ b/mimepart.pas @@ -0,0 +1,1227 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.009.000 | +|==============================================================================| +| Content: MIME support procedures and functions | +|==============================================================================| +| Copyright (c)1999-200812 | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2012. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(MIME part handling) +Handling with MIME parts. + +Used RFC: RFC-2045 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$Q-} +{$R-} +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit mimepart; + +interface + +uses + SysUtils, Classes, + synafpc, + synachar, synacode, synautil, mimeinln; + +type + + TMimePart = class; + + {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for + easy walking through MIME subparts.} + THookWalkPart = procedure(const Sender: TMimePart) of object; + + {:The four types of MIME parts. (textual, multipart, message or any other + binary data.)} + TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY); + + {:The various types of possible part encodings.} + TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE, + ME_BASE64, ME_UU, ME_XX); + + {:@abstract(Object for working with parts of MIME e-mail.) + Each TMimePart object can handle any number of nested subparts as new + TMimepart objects. It can handle any tree hierarchy structure of nested MIME + subparts itself. + + Basic tasks are: + + Decoding of MIME message: + - store message into Lines property + - call DecomposeParts. Now you have decomposed MIME parts in all nested levels! + - now you can explore all properties and subparts. (You can use WalkPart method) + - if you need decode part, call DecodePart. + + Encoding of MIME message: + + - if you need multipart message, you must create subpart by AddSubPart. + - set all properties of all parts. + - set content of part into DecodedLines stream + - encode this stream by EncodePart. + - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!) + - encoded MIME message is stored in Lines property. + } + TMimePart = class(TObject) + private + FPrimary: string; + FPrimaryCode: TMimePrimary; + FSecondary: string; + FEncoding: string; + FEncodingCode: TMimeEncoding; + FDefaultCharset: string; + FCharset: string; + FCharsetCode: TMimeChar; + FTargetCharset: TMimeChar; + FDescription: string; + FDisposition: string; + FContentID: string; + FBoundary: string; + FFileName: string; + FLines: TStringList; + FPartBody: TStringList; + FHeaders: TStringList; + FPrePart: TStringList; + FPostPart: TStringList; + FDecodedLines: TMemoryStream; + FSubParts: TList; + FOnWalkPart: THookWalkPart; + FMaxLineLength: integer; + FSubLevel: integer; + FMaxSubLevel: integer; + FAttachInside: boolean; + FConvertCharset: Boolean; + FForcedHTMLConvert: Boolean; + FBinaryDecomposer: boolean; + procedure SetPrimary(Value: string); + procedure SetEncoding(Value: string); + procedure SetCharset(Value: string); + function IsUUcode(Value: string): boolean; + public + constructor Create; + destructor Destroy; override; + + {:Assign content of another object to this object. (Only this part, + not subparts!)} + procedure Assign(Value: TMimePart); + + {:Assign content of another object to this object. (With all subparts!)} + procedure AssignSubParts(Value: TMimePart); + + {:Clear all data values to default values. It also call @link(ClearSubparts).} + procedure Clear; + + {:Decode Mime part from @link(Lines) to @link(DecodedLines).} + procedure DecodePart; + + {:Parse header lines from Headers property into another properties.} + procedure DecodePartHeader; + + {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime + headers.} + procedure EncodePart; + + {:Build header lines in Headers property from another properties.} + procedure EncodePartHeader; + + {:generate primary and secondary mime type from filename extension in value. + If type not recognised, it return 'Application/octet-string' type.} + procedure MimeTypeFromExt(Value: string); + + {:Return number of decomposed subparts. (On this level! Each of this + subparts can hold any number of their own nested subparts!)} + function GetSubPartCount: integer; + + {:Get nested subpart object as new TMimePart. For getting maximum possible + index you can use @link(GetSubPartCount) method.} + function GetSubPart(index: integer): TMimePart; + + {:delete subpart on given index.} + procedure DeleteSubPart(index: integer); + + {:Clear and destroy all subpart TMimePart objects.} + procedure ClearSubParts; + + {:Add and create new subpart.} + function AddSubPart: TMimePart; + + {:E-mail message in @link(Lines) property is parsed into this object. + E-mail headers are stored in @link(Headers) property and is parsed into + another properties automaticly. Not need call @link(DecodePartHeader)! + Content of message (part) is stored into @link(PartBody) property. This + part is in undecoded form! If you need decode it, then you must call + @link(DecodePart) method by your hands. Lot of another properties is filled + also. + + Decoding of parts you must call separately due performance reasons. (Not + needed to decode all parts in all reasons.) + + For each MIME subpart is created new TMimepart object (accessible via + method @link(GetSubPart)).} + procedure DecomposeParts; + + {pf} + {: HTTP message is received by @link(THTTPSend) component in two parts: + headers are stored in @link(THTTPSend.Headers) and a body in memory stream + @link(THTTPSend.Document). + + On the top of it, HTTP connections are always 8-bit, hence data are + transferred in native format i.e. no transfer encoding is applied. + + This method operates the similiar way and produces the same + result as @link(DecomposeParts). + } + procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PChar); + {/pf} + + {:This part and all subparts is composed into one MIME message stored in + @link(Lines) property.} + procedure ComposeParts; + + {:By calling this method is called @link(OnWalkPart) event for each part + and their subparts. It is very good for calling some code for each part in + MIME message} + procedure WalkPart; + + {:Return @true when is possible create next subpart. (@link(maxSublevel) + is still not reached)} + function CanSubPart: boolean; + published + {:Primary Mime type of part. (i.e. 'application') Writing to this property + automaticly generate value of @link(PrimaryCode).} + property Primary: string read FPrimary write SetPrimary; + + {:String representation of used Mime encoding in part. (i.e. 'base64') + Writing to this property automaticly generate value of @link(EncodingCode).} + property Encoding: string read FEncoding write SetEncoding; + + {:String representation of used Mime charset in part. (i.e. 'iso-8859-1') + Writing to this property automaticly generate value of @link(CharsetCode). + Charset is used only for text parts.} + property Charset: string read FCharset write SetCharset; + + {:Define default charset for decoding text MIME parts without charset + specification. Default value is 'ISO-8859-1' by RCF documents. + But Microsoft Outlook use windows codings as default. This property allows + properly decode textual parts from some broken versions of Microsoft + Outlook. (this is bad software!)} + property DefaultCharset: string read FDefaultCharset write FDefaultCharset; + + {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART, + MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.} + property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode; + + {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT, + ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is + ME_7BIT.} + property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode; + + {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.} + property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; + + {:System charset type. Default value is charset used by default in your + operating system.} + property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset; + + {:If @true, then do internal charset translation of part content between @link(CharsetCode) + and @link(TargetCharset)} + property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset; + + {:If @true, then allways do internal charset translation of HTML parts + by MIME even it have their own charset in META tag. Default is @false.} + property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert; + + {:Secondary Mime type of part. (i.e. 'mixed')} + property Secondary: string read FSecondary Write FSecondary; + + {:Description of Mime part.} + property Description: string read FDescription Write FDescription; + + {:Value of content disposition field. (i.e. 'inline' or 'attachment')} + property Disposition: string read FDisposition Write FDisposition; + + {:Content ID.} + property ContentID: string read FContentID Write FContentID; + + {:Boundary delimiter of multipart Mime part. Used only in multipart part.} + property Boundary: string read FBoundary Write FBoundary; + + {:Filename of file in binary part.} + property FileName: string read FFileName Write FFileName; + + {:String list with lines contains mime part (It can be a full message).} + property Lines: TStringList read FLines; + + {:Encoded form of MIME part data.} + property PartBody: TStringList read FPartBody; + + {:All header lines of MIME part.} + property Headers: TStringList read FHeaders; + + {:On multipart this contains part of message between first line of message + and first boundary.} + property PrePart: TStringList read FPrePart; + + {:On multipart this contains part of message between last boundary and end + of message.} + property PostPart: TStringList read FPostPart; + + {:Stream with decoded form of budy part.} + property DecodedLines: TMemoryStream read FDecodedLines; + + {:Show nested level in subpart tree. Value 0 means root part. 1 means + subpart from this root. etc.} + property SubLevel: integer read FSubLevel write FSubLevel; + + {:Specify maximum sublevel value for decomposing.} + property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel; + + {:When is @true, then this part maybe(!) have included some uuencoded binary + data.} + property AttachInside: boolean read FAttachInside; + + {:Here you can assign hook procedure for walking through all part and their + subparts.} + property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; + + {:Here you can specify maximum line length for encoding of MIME part. + If line is longer, then is splitted by standard of MIME. Correct MIME + mailers can de-split this line into original length.} + property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; + end; + +const + MaxMimeType = 25; + MimeType: array[0..MaxMimeType, 0..2] of string = + ( + ('AU', 'audio', 'basic'), + ('AVI', 'video', 'x-msvideo'), + ('BMP', 'image', 'BMP'), + ('DOC', 'application', 'MSWord'), + ('EPS', 'application', 'Postscript'), + ('GIF', 'image', 'GIF'), + ('JPEG', 'image', 'JPEG'), + ('JPG', 'image', 'JPEG'), + ('MID', 'audio', 'midi'), + ('MOV', 'video', 'quicktime'), + ('MPEG', 'video', 'MPEG'), + ('MPG', 'video', 'MPEG'), + ('MP2', 'audio', 'mpeg'), + ('MP3', 'audio', 'mpeg'), + ('PDF', 'application', 'PDF'), + ('PNG', 'image', 'PNG'), + ('PS', 'application', 'Postscript'), + ('QT', 'video', 'quicktime'), + ('RA', 'audio', 'x-realaudio'), + ('RTF', 'application', 'RTF'), + ('SND', 'audio', 'basic'), + ('TIF', 'image', 'TIFF'), + ('TIFF', 'image', 'TIFF'), + ('WAV', 'audio', 'x-wav'), + ('WPD', 'application', 'Wordperfect5.1'), + ('ZIP', 'application', 'ZIP') + ); + +{:Generates a unique boundary string.} +function GenerateBoundary: string; + +implementation + +{==============================================================================} + +constructor TMIMEPart.Create; +begin + inherited Create; + FOnWalkPart := nil; + FLines := TStringList.Create; + FPartBody := TStringList.Create; + FHeaders := TStringList.Create; + FPrePart := TStringList.Create; + FPostPart := TStringList.Create; + FDecodedLines := TMemoryStream.Create; + FSubParts := TList.Create; + FTargetCharset := GetCurCP; + //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default + //system charset instead. + FDefaultCharset := GetIDFromCP(GetCurCP); + FMaxLineLength := 78; + FSubLevel := 0; + FMaxSubLevel := -1; + FAttachInside := false; + FConvertCharset := true; + FForcedHTMLConvert := false; +end; + +destructor TMIMEPart.Destroy; +begin + ClearSubParts; + FSubParts.Free; + FDecodedLines.Free; + FPartBody.Free; + FLines.Free; + FHeaders.Free; + FPrePart.Free; + FPostPart.Free; + inherited Destroy; +end; + +{==============================================================================} + +procedure TMIMEPart.Clear; +begin + FPrimary := ''; + FEncoding := ''; + FCharset := ''; + FPrimaryCode := MP_TEXT; + FEncodingCode := ME_7BIT; + FCharsetCode := ISO_8859_1; + FTargetCharset := GetCurCP; + FSecondary := ''; + FDisposition := ''; + FContentID := ''; + FDescription := ''; + FBoundary := ''; + FFileName := ''; + FAttachInside := False; + FPartBody.Clear; + FHeaders.Clear; + FPrePart.Clear; + FPostPart.Clear; + FDecodedLines.Clear; + FConvertCharset := true; + FForcedHTMLConvert := false; + ClearSubParts; +end; + +{==============================================================================} + +procedure TMIMEPart.Assign(Value: TMimePart); +begin + Primary := Value.Primary; + Encoding := Value.Encoding; + Charset := Value.Charset; + DefaultCharset := Value.DefaultCharset; + PrimaryCode := Value.PrimaryCode; + EncodingCode := Value.EncodingCode; + CharsetCode := Value.CharsetCode; + TargetCharset := Value.TargetCharset; + Secondary := Value.Secondary; + Description := Value.Description; + Disposition := Value.Disposition; + ContentID := Value.ContentID; + Boundary := Value.Boundary; + FileName := Value.FileName; + Lines.Assign(Value.Lines); + PartBody.Assign(Value.PartBody); + Headers.Assign(Value.Headers); + PrePart.Assign(Value.PrePart); + PostPart.Assign(Value.PostPart); + MaxLineLength := Value.MaxLineLength; + FAttachInside := Value.AttachInside; + FConvertCharset := Value.ConvertCharset; +end; + +{==============================================================================} + +procedure TMIMEPart.AssignSubParts(Value: TMimePart); +var + n: integer; + p: TMimePart; +begin + Assign(Value); + for n := 0 to Value.GetSubPartCount - 1 do + begin + p := AddSubPart; + p.AssignSubParts(Value.GetSubPart(n)); + end; +end; + +{==============================================================================} + +function TMIMEPart.GetSubPartCount: integer; +begin + Result := FSubParts.Count; +end; + +{==============================================================================} + +function TMIMEPart.GetSubPart(index: integer): TMimePart; +begin + Result := nil; + if Index < GetSubPartCount then + Result := TMimePart(FSubParts[Index]); +end; + +{==============================================================================} + +procedure TMIMEPart.DeleteSubPart(index: integer); +begin + if Index < GetSubPartCount then + begin + GetSubPart(Index).Free; + FSubParts.Delete(Index); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.ClearSubParts; +var + n: integer; +begin + for n := 0 to GetSubPartCount - 1 do + TMimePart(FSubParts[n]).Free; + FSubParts.Clear; +end; + +{==============================================================================} + +function TMIMEPart.AddSubPart: TMimePart; +begin + Result := TMimePart.Create; + Result.DefaultCharset := FDefaultCharset; + FSubParts.Add(Result); + Result.SubLevel := FSubLevel + 1; + Result.MaxSubLevel := FMaxSubLevel; +end; + +{==============================================================================} + +procedure TMIMEPart.DecomposeParts; +var + x: integer; + s: string; + Mime: TMimePart; + + procedure SkipEmpty; + begin + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + if s <> '' then + Break; + Inc(x); + end; + end; + +begin + FBinaryDecomposer := false; + x := 0; + Clear; + //extract headers + while FLines.Count > x do + begin + s := NormalizeHeader(FLines, x); + if s = '' then + Break; + FHeaders.Add(s); + end; + DecodePartHeader; + //extract prepart + if FPrimaryCode = MP_MULTIPART then + begin + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + if TrimRight(s) = '--' + FBoundary then + Break; + FPrePart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; + //extract body part + if FPrimaryCode = MP_MULTIPART then + begin + repeat + if CanSubPart then + begin + Mime := AddSubPart; + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + if Pos('--' + FBoundary, s) = 1 then + Break; + Mime.Lines.Add(s); + end; + Mime.DecomposeParts; + end + else + begin + s := FLines[x]; + Inc(x); + FPartBody.Add(s); + end; + if x >= FLines.Count then + break; + until s = '--' + FBoundary + '--'; + end; + if (FPrimaryCode = MP_MESSAGE) and CanSubPart then + begin + Mime := AddSubPart; + SkipEmpty; + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + Mime.Lines.Add(s); + end; + Mime.DecomposeParts; + end + else + begin + while FLines.Count > x do + begin + s := FLines[x]; + Inc(x); + FPartBody.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; + //extract postpart + if FPrimaryCode = MP_MULTIPART then + begin + while FLines.Count > x do + begin + s := TrimRight(FLines[x]); + Inc(x); + FPostPart.Add(s); + if not FAttachInside then + FAttachInside := IsUUcode(s); + end; + end; +end; + +procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PChar); +var + x: integer; + s: ANSIString; + Mime: TMimePart; + BOP: PChar; // Beginning of Part + EOP: PChar; // End of Part + + function ___HasUUCode(ALines:TStrings): boolean; + var + x: integer; + begin + Result := FALSE; + for x:=0 to ALines.Count-1 do + if IsUUcode(ALInes[x]) then + begin + Result := TRUE; + exit; + end; + end; + +begin + FBinaryDecomposer := true; + Clear; + // Parse passed headers (THTTPSend returns HTTP headers and body separately) + x := 0; + while x 0 then + x := d1 + else + if d3 > 0 then + x := d3 + else + x := d2 - 1; + t := Copy(s, 1, x); + Delete(s, 1, x); + end; + Flines.Add(t); + until s = ''; + end; + + Flines.Add(''); + //add body + //if multipart + if FPrimaryCode = MP_MULTIPART then + begin + Flines.AddStrings(FPrePart); + for n := 0 to GetSubPartCount - 1 do + begin + Flines.Add('--' + FBoundary); + mime := GetSubPart(n); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + end; + Flines.Add('--' + FBoundary + '--'); + Flines.AddStrings(FPostPart); + end; + //if message + if FPrimaryCode = MP_MESSAGE then + begin + if GetSubPartCount > 0 then + begin + mime := GetSubPart(0); + mime.ComposeParts; + FLines.AddStrings(mime.Lines); + end; + end + else + //if normal part + begin + FLines.AddStrings(FPartBody); + end; +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePart; +var + n: Integer; + s, t, t2: string; + b: Boolean; +begin + FDecodedLines.Clear; + {pf} + // The part decomposer passes data via TStringList which appends trailing line + // break inherently. But in a case of native 8-bit data transferred withouth + // encoding (default e.g. for HTTP protocol), the redundant line terminators + // has to be removed + if FBinaryDecomposer and (FPartBody.Count=1) then + begin + case FEncodingCode of + ME_QUOTED_PRINTABLE: + s := DecodeQuotedPrintable(FPartBody[0]); + ME_BASE64: + s := DecodeBase64(FPartBody[0]); + ME_UU, ME_XX: + begin + s := ''; + for n := 0 to FPartBody.Count - 1 do + if FEncodingCode = ME_UU then + s := s + DecodeUU(FPartBody[n]) + else + s := s + DecodeXX(FPartBody[n]); + end; + else + s := FPartBody[0]; + end; + end + else + {/pf} + case FEncodingCode of + ME_QUOTED_PRINTABLE: + s := DecodeQuotedPrintable(FPartBody.Text); + ME_BASE64: + s := DecodeBase64(FPartBody.Text); + ME_UU, ME_XX: + begin + s := ''; + for n := 0 to FPartBody.Count - 1 do + if FEncodingCode = ME_UU then + s := s + DecodeUU(FPartBody[n]) + else + s := s + DecodeXX(FPartBody[n]); + end; + else + s := FPartBody.Text; + end; + if FConvertCharset and (FPrimaryCode = MP_TEXT) then + if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then + begin + b := false; + t2 := uppercase(s); + t := SeparateLeft(t2, ''); + if length(t) <> length(s) then + begin + t := SeparateRight(t, ''); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; + //workaround for shitty M$ Outlook 11 which is placing this information + //outside section + if not b then + begin + t := Copy(t2, 1, 2048); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; + if not b then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + end + else + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + WriteStrToStream(FDecodedLines, s); + FDecodedLines.Seek(0, soFromBeginning); +end; + +{==============================================================================} + +procedure TMIMEPart.DecodePartHeader; +var + n: integer; + s, su, fn: string; + st, st2: string; +begin + Primary := 'text'; + FSecondary := 'plain'; + FDescription := ''; + Charset := FDefaultCharset; + FFileName := ''; + //was 7bit before, but this is more compatible with RFC-ignorant outlook + Encoding := '8BIT'; + FDisposition := ''; + FContentID := ''; + fn := ''; + for n := 0 to FHeaders.Count - 1 do + if FHeaders[n] <> '' then + begin + s := FHeaders[n]; + su := UpperCase(s); + if Pos('CONTENT-TYPE:', su) = 1 then + begin + st := Trim(SeparateRight(su, ':')); + st2 := Trim(SeparateLeft(st, ';')); + Primary := Trim(SeparateLeft(st2, '/')); + FSecondary := Trim(SeparateRight(st2, '/')); + if (FSecondary = Primary) and (Pos('/', st2) < 1) then + FSecondary := ''; + case FPrimaryCode of + MP_TEXT: + begin + Charset := UpperCase(GetParameter(s, 'charset')); + FFileName := GetParameter(s, 'name'); + end; + MP_MULTIPART: + FBoundary := GetParameter(s, 'Boundary'); + MP_MESSAGE: + begin + end; + MP_BINARY: + FFileName := GetParameter(s, 'name'); + end; + end; + if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then + Encoding := Trim(SeparateRight(su, ':')); + if Pos('CONTENT-DESCRIPTION:', su) = 1 then + FDescription := Trim(SeparateRight(s, ':')); + if Pos('CONTENT-DISPOSITION:', su) = 1 then + begin + FDisposition := SeparateRight(su, ':'); + FDisposition := Trim(SeparateLeft(FDisposition, ';')); + fn := GetParameter(s, 'FileName'); + end; + if Pos('CONTENT-ID:', su) = 1 then + FContentID := Trim(SeparateRight(s, ':')); + end; + if fn <> '' then + FFileName := fn; + FFileName := InlineDecode(FFileName, FTargetCharset); + FFileName := ExtractFileName(FFileName); +end; + +{==============================================================================} + +procedure TMIMEPart.EncodePart; +var + l: TStringList; + s, t: string; + n, x: Integer; + d1, d2: integer; +begin + if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then + Encoding := 'base64'; + l := TStringList.Create; + FPartBody.Clear; + FDecodedLines.Seek(0, soFromBeginning); + try + case FPrimaryCode of + MP_MULTIPART, MP_MESSAGE: + FPartBody.LoadFromStream(FDecodedLines); + MP_TEXT, MP_BINARY: + begin + s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size); + if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then + s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode); + if FEncodingCode = ME_BASE64 then + begin + x := 1; + while x <= length(s) do + begin + t := copy(s, x, 54); + x := x + length(t); + t := EncodeBase64(t); + FPartBody.Add(t); + end; + end + else + begin + if FPrimaryCode = MP_BINARY then + l.Add(s) + else + l.Text := s; + for n := 0 to l.Count - 1 do + begin + s := l[n]; + if FEncodingCode = ME_QUOTED_PRINTABLE then + begin + s := EncodeQuotedPrintable(s); + repeat + if Length(s) < FMaxLineLength then + begin + t := s; + s := ''; + end + else + begin + d1 := RPosEx('=', s, FMaxLineLength); + d2 := RPosEx(' ', s, FMaxLineLength); + if (d1 = 0) and (d2 = 0) then + x := FMaxLineLength + else + if d1 > d2 then + x := d1 - 1 + else + x := d2 - 1; + if x = 0 then + x := FMaxLineLength; + t := Copy(s, 1, x); + Delete(s, 1, x); + if s <> '' then + t := t + '='; + end; + FPartBody.Add(t); + until s = ''; + end + else + FPartBody.Add(s); + end; + if (FPrimaryCode = MP_BINARY) + and (FEncodingCode = ME_QUOTED_PRINTABLE) then + FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '='; + end; + end; + end; + finally + l.Free; + end; +end; + +{==============================================================================} + +procedure TMIMEPart.EncodePartHeader; +var + s: string; +begin + FHeaders.Clear; + if FSecondary = '' then + case FPrimaryCode of + MP_TEXT: + FSecondary := 'plain'; + MP_MULTIPART: + FSecondary := 'mixed'; + MP_MESSAGE: + FSecondary := 'rfc822'; + MP_BINARY: + FSecondary := 'octet-stream'; + end; + if FDescription <> '' then + FHeaders.Insert(0, 'Content-Description: ' + FDescription); + if FDisposition <> '' then + begin + s := ''; + if FFileName <> '' then + s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); + FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); + end; + if FContentID <> '' then + FHeaders.Insert(0, 'Content-ID: ' + FContentID); + + case FEncodingCode of + ME_7BIT: + s := '7bit'; + ME_8BIT: + s := '8bit'; + ME_QUOTED_PRINTABLE: + s := 'Quoted-printable'; + ME_BASE64: + s := 'Base64'; + end; + case FPrimaryCode of + MP_TEXT, + MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s); + end; + case FPrimaryCode of + MP_TEXT: + s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); + MP_MULTIPART: + s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; + MP_MESSAGE, MP_BINARY: + s := FPrimary + '/' + FSecondary; + end; + if FFileName <> '' then + s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); + FHeaders.Insert(0, 'Content-type: ' + s); +end; + +{==============================================================================} + +procedure TMIMEPart.MimeTypeFromExt(Value: string); +var + s: string; + n: Integer; +begin + Primary := ''; + FSecondary := ''; + s := UpperCase(ExtractFileExt(Value)); + if s = '' then + s := UpperCase(Value); + s := SeparateRight(s, '.'); + for n := 0 to MaxMimeType do + if MimeType[n, 0] = s then + begin + Primary := MimeType[n, 1]; + FSecondary := MimeType[n, 2]; + Break; + end; + if Primary = '' then + Primary := 'application'; + if FSecondary = '' then + FSecondary := 'octet-stream'; +end; + +{==============================================================================} + +procedure TMIMEPart.WalkPart; +var + n: integer; + m: TMimepart; +begin + if assigned(OnWalkPart) then + begin + OnWalkPart(self); + for n := 0 to GetSubPartCount - 1 do + begin + m := GetSubPart(n); + m.OnWalkPart := OnWalkPart; + m.WalkPart; + end; + end; +end; + +{==============================================================================} + +procedure TMIMEPart.SetPrimary(Value: string); +var + s: string; +begin + FPrimary := Value; + s := UpperCase(Value); + FPrimaryCode := MP_BINARY; + if Pos('TEXT', s) = 1 then + FPrimaryCode := MP_TEXT; + if Pos('MULTIPART', s) = 1 then + FPrimaryCode := MP_MULTIPART; + if Pos('MESSAGE', s) = 1 then + FPrimaryCode := MP_MESSAGE; +end; + +procedure TMIMEPart.SetEncoding(Value: string); +var + s: string; +begin + FEncoding := Value; + s := UpperCase(Value); + FEncodingCode := ME_7BIT; + if Pos('8BIT', s) = 1 then + FEncodingCode := ME_8BIT; + if Pos('QUOTED-PRINTABLE', s) = 1 then + FEncodingCode := ME_QUOTED_PRINTABLE; + if Pos('BASE64', s) = 1 then + FEncodingCode := ME_BASE64; + if Pos('X-UU', s) = 1 then + FEncodingCode := ME_UU; + if Pos('X-XX', s) = 1 then + FEncodingCode := ME_XX; +end; + +procedure TMIMEPart.SetCharset(Value: string); +begin + if value <> '' then + begin + FCharset := Value; + FCharsetCode := GetCPFromID(Value); + end; +end; + +function TMIMEPart.CanSubPart: boolean; +begin + Result := True; + if FMaxSubLevel <> -1 then + Result := FMaxSubLevel > FSubLevel; +end; + +function TMIMEPart.IsUUcode(Value: string): boolean; +begin + Value := UpperCase(Value); + Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> ''); +end; + +{==============================================================================} + +function GenerateBoundary: string; +var + x, y: Integer; +begin + y := GetTick; + x := y; + while TickDelta(y, x) = 0 do + begin + Sleep(1); + x := GetTick; + end; + Randomize; + y := Random(MaxInt); + Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary'; +end; + +end. diff --git a/nntpsend.pas b/nntpsend.pas new file mode 100644 index 0000000..0a28179 --- /dev/null +++ b/nntpsend.pas @@ -0,0 +1,483 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.005.003 | +|==============================================================================| +| Content: NNTP client | +|==============================================================================| +| Copyright (c)1999-2011, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(NNTP client) +NNTP (network news transfer protocol) + +Used RFC: RFC-977, RFC-2980 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit nntpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cNNTPProtocol = '119'; + +type + + {:abstract(Implementation of Network News Transfer Protocol. + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TNNTPSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FData: TStringList; + FDataToSend: TStringList; + FAutoTLS: Boolean; + FFullSSL: Boolean; + FNNTPcap: TStringList; + function ReadResult: Integer; + function ReadData: boolean; + function SendData: boolean; + function Connect: Boolean; + public + constructor Create; + destructor Destroy; override; + + {:Connects to NNTP server and begin session.} + function Login: Boolean; + + {:Logout from NNTP server and terminate session.} + function Logout: Boolean; + + {:By this you can call any NNTP command.} + function DoCommand(const Command: string): boolean; + + {:by this you can call any NNTP command. This variant is used for commands + for download information from server.} + function DoCommandRead(const Command: string): boolean; + + {:by this you can call any NNTP command. This variant is used for commands + for upload information to server.} + function DoCommandWrite(const Command: string): boolean; + + {:Download full message to @link(data) property. Value can be number of + message or message-id (in brackets).} + function GetArticle(const Value: string): Boolean; + + {:Download only body of message to @link(data) property. Value can be number + of message or message-id (in brackets).} + function GetBody(const Value: string): Boolean; + + {:Download only headers of message to @link(data) property. Value can be + number of message or message-id (in brackets).} + function GetHead(const Value: string): Boolean; + + {:Get message status. Value can be number of message or message-id + (in brackets).} + function GetStat(const Value: string): Boolean; + + {:Select given group.} + function SelectGroup(const Value: string): Boolean; + + {:Tell to server 'I have mesage with given message-ID.' If server need this + message, message is uploaded to server.} + function IHave(const MessID: string): Boolean; + + {:Move message pointer to last item in group.} + function GotoLast: Boolean; + + {:Move message pointer to next item in group.} + function GotoNext: Boolean; + + {:Download to @link(data) property list of all groups on NNTP server.} + function ListGroups: Boolean; + + {:Download to @link(data) property list of all groups created after given time.} + function ListNewGroups(Since: TDateTime): Boolean; + + {:Download to @link(data) property list of message-ids in given group since + given time.} + function NewArticles(const Group: string; Since: TDateTime): Boolean; + + {:Upload new article to server. (for new messages by you)} + function PostArticle: Boolean; + + {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP + server'.} + function SwitchToSlave: Boolean; + + {:Call NNTP XOVER command.} + function Xover(xoStart, xoEnd: string): boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:Try to find given capability in extension list. This list is getted after + successful login to NNTP server. If extension capability is not found, + then return is empty string.} + function FindCap(const Value: string): string; + + {:Try get list of server extensions. List is returned in @link(data) property.} + function ListExtensions: Boolean; + published + {:Result code number of last operation.} + property ResultCode: Integer read FResultCode; + + {:String description of last result code from NNTP server.} + property ResultString: string read FResultString; + + {:Readed data. (message, etc.)} + property Data: TStringList read FData; + + {:If is set to @true, then upgrade to SSL/TLS mode after login if remote + server support it.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + end; + +implementation + +constructor TNNTPSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FData := TStringList.Create; + FDataToSend := TStringList.Create; + FNNTPcap := TStringList.Create; + FSock.ConvertLineEnd := True; + FTimeout := 60000; + FTargetPort := cNNTPProtocol; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TNNTPSend.Destroy; +begin + FSock.Free; + FDataToSend.Free; + FData.Free; + FNNTPcap.Free; + inherited Destroy; +end; + +function TNNTPSend.ReadResult: Integer; +var + s: string; +begin + Result := 0; + FData.Clear; + s := FSock.RecvString(FTimeout); + FResultString := Copy(s, 5, Length(s) - 4); + if FSock.LastError <> 0 then + Exit; + if Length(s) >= 3 then + Result := StrToIntDef(Copy(s, 1, 3), 0); + FResultCode := Result; +end; + +function TNNTPSend.ReadData: boolean; +var + s: string; +begin + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + break; + if (s <> '') and (s[1] = '.') then + s := Copy(s, 2, Length(s) - 1); + FData.Add(s); + until FSock.LastError <> 0; + Result := FSock.LastError = 0; +end; + +function TNNTPSend.SendData: boolean; +var + s: string; + n: integer; +begin + for n := 0 to FDataToSend.Count - 1 do + begin + s := FDataToSend[n]; + if (s <> '') and (s[1] = '.') then + s := s + '.'; + FSock.SendString(s + CRLF); + if FSock.LastError <> 0 then + break; + end; + if FDataToSend.Count = 0 then + FSock.SendString(CRLF); + if FSock.LastError = 0 then + FSock.SendString('.' + CRLF); + FDataToSend.Clear; + Result := FSock.LastError = 0; +end; + +function TNNTPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TNNTPSend.Login: Boolean; +begin + Result := False; + FNNTPcap.Clear; + if not Connect then + Exit; + Result := (ReadResult div 100) = 2; + if Result then + begin + ListExtensions; + FNNTPcap.Assign(Fdata); + if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then + Result := StartTLS; + end; + if (FUsername <> '') and Result then + begin + FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); + if (ReadResult div 100) = 3 then + begin + FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); + Result := (ReadResult div 100) = 2; + end; + end; +end; + +function TNNTPSend.Logout: Boolean; +begin + FSock.SendString('QUIT' + CRLF); + Result := (ReadResult div 100) = 2; + FSock.CloseSocket; +end; + +function TNNTPSend.DoCommand(const Command: string): Boolean; +begin + FSock.SendString(Command + CRLF); + Result := (ReadResult div 100) = 2; + Result := Result and (FSock.LastError = 0); +end; + +function TNNTPSend.DoCommandRead(const Command: string): Boolean; +begin + Result := DoCommand(Command); + if Result then + begin + Result := ReadData; + Result := Result and (FSock.LastError = 0); + end; +end; + +function TNNTPSend.DoCommandWrite(const Command: string): Boolean; +var + x: integer; +begin + FDataToSend.Assign(FData); + FSock.SendString(Command + CRLF); + x := (ReadResult div 100); + if x = 3 then + begin + SendData; + x := (ReadResult div 100); + end; + Result := x = 2; + Result := Result and (FSock.LastError = 0); +end; + +function TNNTPSend.GetArticle(const Value: string): Boolean; +var + s: string; +begin + s := 'ARTICLE'; + if Value <> '' then + s := s + ' ' + Value; + Result := DoCommandRead(s); +end; + +function TNNTPSend.GetBody(const Value: string): Boolean; +var + s: string; +begin + s := 'BODY'; + if Value <> '' then + s := s + ' ' + Value; + Result := DoCommandRead(s); +end; + +function TNNTPSend.GetHead(const Value: string): Boolean; +var + s: string; +begin + s := 'HEAD'; + if Value <> '' then + s := s + ' ' + Value; + Result := DoCommandRead(s); +end; + +function TNNTPSend.GetStat(const Value: string): Boolean; +var + s: string; +begin + s := 'STAT'; + if Value <> '' then + s := s + ' ' + Value; + Result := DoCommand(s); +end; + +function TNNTPSend.SelectGroup(const Value: string): Boolean; +begin + Result := DoCommand('GROUP ' + Value); +end; + +function TNNTPSend.IHave(const MessID: string): Boolean; +begin + Result := DoCommandWrite('IHAVE ' + MessID); +end; + +function TNNTPSend.GotoLast: Boolean; +begin + Result := DoCommand('LAST'); +end; + +function TNNTPSend.GotoNext: Boolean; +begin + Result := DoCommand('NEXT'); +end; + +function TNNTPSend.ListGroups: Boolean; +begin + Result := DoCommandRead('LIST'); +end; + +function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; +begin + Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); +end; + +function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; +begin + Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); +end; + +function TNNTPSend.PostArticle: Boolean; +begin + Result := DoCommandWrite('POST'); +end; + +function TNNTPSend.SwitchToSlave: Boolean; +begin + Result := DoCommand('SLAVE'); +end; + +function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; +var + s: string; +begin + s := 'XOVER ' + xoStart; + if xoEnd <> xoStart then + s := s + '-' + xoEnd; + Result := DoCommandRead(s); +end; + +function TNNTPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + if DoCommand('STARTTLS') then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + +function TNNTPSend.ListExtensions: Boolean; +begin + Result := DoCommandRead('LIST EXTENSIONS'); +end; + +function TNNTPSend.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FNNTPcap.Count - 1 do + if Pos(s, UpperCase(FNNTPcap[n])) = 1 then + begin + Result := FNNTPcap[n]; + Break; + end; +end; + +{==============================================================================} + +end. diff --git a/pingsend.pas b/pingsend.pas new file mode 100644 index 0000000..95a0c60 --- /dev/null +++ b/pingsend.pas @@ -0,0 +1,728 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.002 | +|==============================================================================| +| Content: PING sender | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(ICMP PING implementation.) +Allows create PING and TRACEROUTE. Or you can diagnose your network. + +This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying + to use RAW sockets. + +Warning: For use of RAW sockets you must have some special rights on some + systems. So, it working allways when you have administator/root rights. + Otherwise you can have problems! + +Note: This unit is NOT portable to .NET! + Use native .NET classes for Ping instead. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +{$IFDEF CIL} + Sorry, this unit is not for .NET! +{$ENDIF} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit pingsend; + +interface + +uses + SysUtils, + synsock, blcksock, synautil, synafpc, synaip +{$IFDEF MSWINDOWS} + , windows +{$ENDIF} + ; + +const + ICMP_ECHO = 8; + ICMP_ECHOREPLY = 0; + ICMP_UNREACH = 3; + ICMP_TIME_EXCEEDED = 11; +//rfc-2292 + ICMP6_ECHO = 128; + ICMP6_ECHOREPLY = 129; + ICMP6_UNREACH = 1; + ICMP6_TIME_EXCEEDED = 3; + +type + {:List of possible ICMP reply packet types.} + TICMPError = ( + IE_NoError, + IE_Other, + IE_TTLExceed, + IE_UnreachOther, + IE_UnreachRoute, + IE_UnreachAdmin, + IE_UnreachAddr, + IE_UnreachPort + ); + + {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)} + TPINGSend = class(TSynaClient) + private + FSock: TICMPBlockSocket; + FBuffer: Ansistring; + FSeq: Integer; + FId: Integer; + FPacketSize: Integer; + FPingTime: Integer; + FIcmpEcho: Byte; + FIcmpEchoReply: Byte; + FIcmpUnreach: Byte; + FReplyFrom: string; + FReplyType: byte; + FReplyCode: byte; + FReplyError: TICMPError; + FReplyErrorDesc: string; + FTTL: Byte; + Fsin: TVarSin; + function Checksum(Value: AnsiString): Word; + function Checksum6(Value: AnsiString): Word; + function ReadPacket: Boolean; + procedure TranslateError; + procedure TranslateErrorIpHlp(value: integer); + function InternalPing(const Host: string): Boolean; + function InternalPingIpHlp(const Host: string): Boolean; + function IsHostIP6(const Host: string): Boolean; + procedure GenErrorDesc; + public + {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is + @true.} + function Ping(const Host: string): Boolean; + constructor Create; + destructor Destroy; override; + published + {:Size of PING packet. Default size is 32 bytes.} + property PacketSize: Integer read FPacketSize Write FPacketSize; + + {:Time between request and reply.} + property PingTime: Integer read FPingTime; + + {:From this address is sended reply for your PING request. It maybe not your + requested destination, when some error occured!} + property ReplyFrom: string read FReplyFrom; + + {:ICMP type of PING reply. Each protocol using another values! For IPv4 and + IPv6 are used different values!} + property ReplyType: byte read FReplyType; + + {:ICMP code of PING reply. Each protocol using another values! For IPv4 and + IPv6 are used different values! For protocol independent value look to + @link(ReplyError)} + property ReplyCode: byte read FReplyCode; + + {:Return type of returned ICMP message. This value is independent on used + protocol!} + property ReplyError: TICMPError read FReplyError; + + {:Return human readable description of returned packet type.} + property ReplyErrorDesc: string read FReplyErrorDesc; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TICMPBlockSocket read FSock; + + {:TTL value for ICMP query} + property TTL: byte read FTTL write FTTL; + end; + +{:A very useful function and example of its use would be found in the TPINGSend + object. Use it to ping to any host. If successful, returns the ping time in + milliseconds. Returns -1 if an error occurred.} +function PingHost(const Host: string): Integer; + +{:A very useful function and example of its use would be found in the TPINGSend + object. Use it to TraceRoute to any host.} +function TraceRouteHost(const Host: string): string; + +implementation + +type + {:Record for ICMP ECHO packet header.} + TIcmpEchoHeader = packed record + i_type: Byte; + i_code: Byte; + i_checkSum: Word; + i_Id: Word; + i_seq: Word; + TimeStamp: integer; + end; + + {:record used internally by TPingSend for compute checksum of ICMPv6 packet + pseudoheader.} + TICMP6Packet = packed record + in_source: TInAddr6; + in_dest: TInAddr6; + Length: integer; + free0: Byte; + free1: Byte; + free2: Byte; + proto: Byte; + end; + +{$IFDEF MSWINDOWS} +const + DLLIcmpName = 'iphlpapi.dll'; +type + TIP_OPTION_INFORMATION = record + TTL: Byte; + TOS: Byte; + Flags: Byte; + OptionsSize: Byte; + OptionsData: PAnsiChar; + end; + PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION; + + TICMP_ECHO_REPLY = record + Address: TInAddr; + Status: integer; + RoundTripTime: integer; + DataSize: Word; + Reserved: Word; + Data: pointer; + Options: TIP_OPTION_INFORMATION; + end; + PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY; + + TICMPV6_ECHO_REPLY = record + Address: TSockAddrIn6; + Status: integer; + RoundTripTime: integer; + end; + PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY; + + TIcmpCreateFile = function: integer; stdcall; + TIcmpCloseHandle = function(handle: integer): boolean; stdcall; + TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; + ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer; + RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; + ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; + TIcmp6CreateFile = function: integer; stdcall; + TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; + ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6; + RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; + ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; + +var + IcmpDllHandle: TLibHandle = 0; + IcmpHelper4: boolean = false; + IcmpHelper6: boolean = false; + IcmpCreateFile: TIcmpCreateFile = nil; + IcmpCloseHandle: TIcmpCloseHandle = nil; + IcmpSendEcho2: TIcmpSendEcho2 = nil; + Icmp6CreateFile: TIcmp6CreateFile = nil; + Icmp6SendEcho2: TIcmp6SendEcho2 = nil; +{$ENDIF} +{==============================================================================} + +constructor TPINGSend.Create; +begin + inherited Create; + FSock := TICMPBlockSocket.Create; + FSock.Owner := self; + {$IFDEF ULTIBO} + FSock.UseConnect := True; //Connect is needed for the ICMP handler to find the matching + {$ENDIF} //socket on receive if multiple pings occur are sent at once. + FTimeout := 5000; + FPacketSize := 32; + FSeq := 0; + Randomize; + FTTL := 128; +end; + +destructor TPINGSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TPINGSend.ReadPacket: Boolean; +begin + FBuffer := FSock.RecvPacket(Ftimeout); + Result := FSock.LastError = 0; +end; + +procedure TPINGSend.GenErrorDesc; +begin + case FReplyError of + IE_NoError: + FReplyErrorDesc := ''; + IE_Other: + FReplyErrorDesc := 'Unknown error'; + IE_TTLExceed: + FReplyErrorDesc := 'TTL Exceeded'; + IE_UnreachOther: + FReplyErrorDesc := 'Unknown unreachable'; + IE_UnreachRoute: + FReplyErrorDesc := 'No route to destination'; + IE_UnreachAdmin: + FReplyErrorDesc := 'Administratively prohibited'; + IE_UnreachAddr: + FReplyErrorDesc := 'Address unreachable'; + IE_UnreachPort: + FReplyErrorDesc := 'Port unreachable'; + end; +end; + +function TPINGSend.IsHostIP6(const Host: string): Boolean; +var + f: integer; +begin + f := AF_UNSPEC; + if IsIp(Host) then + f := AF_INET + else + if IsIp6(Host) then + f := AF_INET6; + synsock.SetVarSin(Fsin, host, '0', f, + IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4); + result := Fsin.sin_family = AF_INET6; +end; + +function TPINGSend.Ping(const Host: string): Boolean; +{$IFDEF MSWINDOWS} +var + b: boolean; +{$ENDIF} +begin + FPingTime := -1; + FReplyFrom := ''; + FReplyType := 0; + FReplyCode := 0; + FReplyError := IE_Other; + GenErrorDesc; + FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); +{$IFDEF MSWINDOWS} + b := IsHostIP6(host); + if not(b) and IcmpHelper4 then + result := InternalPingIpHlp(host) + else + if b and IcmpHelper6 then + result := InternalPingIpHlp(host) + else + result := InternalPing(host); +{$ELSE} + result := InternalPing(host); +{$ENDIF} +end; + +function TPINGSend.InternalPing(const Host: string): Boolean; +var + IPHeadPtr: ^TIPHeader; + IpHdrLen: Integer; + IcmpEchoHeaderPtr: ^TICMPEchoHeader; + t: Boolean; + x: cardinal; + IcmpReqHead: string; +begin + Result := False; + FSock.TTL := FTTL; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(Host, '0'); + if FSock.LastError <> 0 then + Exit; + FSock.SizeRecvBuffer := 60 * 1024; + if FSock.IP6used then + begin + FIcmpEcho := ICMP6_ECHO; + FIcmpEchoReply := ICMP6_ECHOREPLY; + FIcmpUnreach := ICMP6_UNREACH; + end + else + begin + FIcmpEcho := ICMP_ECHO; + FIcmpEchoReply := ICMP_ECHOREPLY; + FIcmpUnreach := ICMP_UNREACH; + end; + IcmpEchoHeaderPtr := Pointer(FBuffer); + with IcmpEchoHeaderPtr^ do + begin + i_type := FIcmpEcho; + i_code := 0; + i_CheckSum := 0; + FId := System.Random(32767); + i_Id := FId; + TimeStamp := GetTick; + Inc(FSeq); + i_Seq := FSeq; + if fSock.IP6used then + i_CheckSum := CheckSum6(FBuffer) + else + i_CheckSum := CheckSum(FBuffer); + end; + FSock.SendString(FBuffer); + // remember first 8 bytes of ICMP packet + IcmpReqHead := Copy(FBuffer, 1, 8); + x := GetTick; + repeat + t := ReadPacket; + if not t then + break; + if fSock.IP6used then + begin +{$IFNDEF MSWINDOWS} + IcmpEchoHeaderPtr := Pointer(FBuffer); +{$ELSE} +//WinXP SP1 with networking update doing this think by another way ;-O +// FBuffer := StringOfChar(#0, 4) + FBuffer; + IcmpEchoHeaderPtr := Pointer(FBuffer); +// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply; +{$ENDIF} + end + else + begin + IPHeadPtr := Pointer(FBuffer); + IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; + IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; + end; + //check for timeout + if TickDelta(x, GetTick) > Cardinal(FTimeout) then + begin + t := false; + Break; + end; + //it discard sometimes possible 'echoes' of previosly sended packet + //or other unwanted ICMP packets... + until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) + and ((IcmpEchoHeaderPtr^.i_id = FId) + or (Pos(IcmpReqHead, FBuffer) > 0)); + if t then + begin + FPingTime := TickDelta(x, GetTick); + FReplyFrom := FSock.GetRemoteSinIP; + FReplyType := IcmpEchoHeaderPtr^.i_type; + FReplyCode := IcmpEchoHeaderPtr^.i_code; + TranslateError; + Result := True; + end; +end; + +function TPINGSend.Checksum(Value: AnsiString): Word; +var + CkSum: integer; + Num, Remain: Integer; + n, i: Integer; +begin + Num := Length(Value) div 2; + Remain := Length(Value) mod 2; + CkSum := 0; + i := 1; + for n := 0 to Num - 1 do + begin + CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i)); + inc(i, 2); + end; + if Remain <> 0 then + CkSum := CkSum + Ord(Value[Length(Value)]); + CkSum := (CkSum shr 16) + (CkSum and $FFFF); + CkSum := CkSum + (CkSum shr 16); + Result := Word(not CkSum); +end; + +function TPINGSend.Checksum6(Value: AnsiString): Word; +const + IOC_OUT = $40000000; + IOC_IN = $80000000; + IOC_INOUT = (IOC_IN or IOC_OUT); + IOC_WS2 = $08000000; + SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT; +{$IFDEF MSWINDOWS} +var + ICMP6Ptr: ^TICMP6Packet; + s: AnsiString; + b: integer; + ip6: TSockAddrIn6; + x: integer; +{$ENDIF} +begin +{$IFDEF MSWINDOWS} + s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value; + ICMP6Ptr := Pointer(s); + x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY, + @FSock.RemoteSin, SizeOf(FSock.RemoteSin), + @ip6, SizeOf(ip6), @b, nil, nil); + if x <> -1 then + ICMP6Ptr^.in_dest := ip6.sin6_addr + else + ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr; + ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr; + ICMP6Ptr^.Length := synsock.htonl(Length(Value)); + ICMP6Ptr^.proto := IPPROTO_ICMPV6; + Result := Checksum(s); +{$ELSE} + Result := 0; +{$ENDIF} +end; + +procedure TPINGSend.TranslateError; +begin + if fSock.IP6used then + begin + case FReplyType of + ICMP6_ECHOREPLY: + FReplyError := IE_NoError; + ICMP6_TIME_EXCEEDED: + FReplyError := IE_TTLExceed; + ICMP6_UNREACH: + case FReplyCode of + 0: + FReplyError := IE_UnreachRoute; + 3: + FReplyError := IE_UnreachAddr; + 4: + FReplyError := IE_UnreachPort; + 1: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_UnreachOther; + end; + else + FReplyError := IE_Other; + end; + end + else + begin + case FReplyType of + ICMP_ECHOREPLY: + FReplyError := IE_NoError; + ICMP_TIME_EXCEEDED: + FReplyError := IE_TTLExceed; + ICMP_UNREACH: + case FReplyCode of + 0: + FReplyError := IE_UnreachRoute; + 1: + FReplyError := IE_UnreachAddr; + 3: + FReplyError := IE_UnreachPort; + 13: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_UnreachOther; + end; + else + FReplyError := IE_Other; + end; + end; + GenErrorDesc; +end; + +procedure TPINGSend.TranslateErrorIpHlp(value: integer); +begin + case value of + 11000, 0: + FReplyError := IE_NoError; + 11013: + FReplyError := IE_TTLExceed; + 11002: + FReplyError := IE_UnreachRoute; + 11003: + FReplyError := IE_UnreachAddr; + 11005: + FReplyError := IE_UnreachPort; + 11004: + FReplyError := IE_UnreachAdmin; + else + FReplyError := IE_Other; + end; + GenErrorDesc; +end; + +function TPINGSend.InternalPingIpHlp(const Host: string): Boolean; +{$IFDEF MSWINDOWS} +var + PingIp6: boolean; + PingHandle: integer; + r: integer; + ipo: TIP_OPTION_INFORMATION; + RBuff: Ansistring; + ip4reply: PICMP_ECHO_REPLY; + ip6reply: PICMPV6_ECHO_REPLY; + ip6: TSockAddrIn6; +begin + Result := False; + PingIp6 := Fsin.sin_family = AF_INET6; + if pingIp6 then + PingHandle := Icmp6CreateFile + else + PingHandle := IcmpCreateFile; + if PingHandle <> -1 then + begin + try + ipo.TTL := FTTL; + ipo.TOS := 0; + ipo.Flags := 0; + ipo.OptionsSize := 0; + ipo.OptionsData := nil; + setlength(RBuff, 4096); + if pingIp6 then + begin + FillChar(ip6, sizeof(ip6), 0); + r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin, + PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + RBuff := #0 + #0 + RBuff; + ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip6reply^.RoundTripTime; + ip6reply^.Address.sin6_family := AF_INET6; + FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address)); + TranslateErrorIpHlp(ip6reply^.Status); + Result := True; + end; + end + else + begin + r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr, + PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); + if r > 0 then + begin + ip4reply := PICMP_ECHO_REPLY(pointer(RBuff)); + FPingTime := ip4reply^.RoundTripTime; + FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr)); + TranslateErrorIpHlp(ip4reply^.Status); + Result := True; + end; + end + finally + IcmpCloseHandle(PingHandle); + end; + end; +end; +{$ELSE} +begin + result := false; +end; +{$ENDIF} + +{==============================================================================} + +function PingHost(const Host: string): Integer; +begin + with TPINGSend.Create do + try + Result := -1; + if Ping(Host) then + if ReplyError = IE_NoError then + Result := PingTime; + finally + Free; + end; +end; + +function TraceRouteHost(const Host: string): string; +var + Ping: TPingSend; + ttl : byte; +begin + Result := ''; + Ping := TPINGSend.Create; + try + ttl := 1; + repeat + ping.TTL := ttl; + inc(ttl); + if ttl > 30 then + Break; + if not ping.Ping(Host) then + begin + Result := Result + cAnyHost+ ' Timeout' + CRLF; + continue; + end; + if (ping.ReplyError <> IE_NoError) + and (ping.ReplyError <> IE_TTLExceed) then + begin + Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF; + break; + end; + Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF; + until ping.ReplyError = IE_NoError; + finally + Ping.Free; + end; +end; + +{$IFDEF MSWINDOWS} +initialization +begin + IcmpHelper4 := false; + IcmpHelper6 := false; + IcmpDllHandle := LoadLibrary(DLLIcmpName); + if IcmpDllHandle <> 0 then + begin + IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile'); + IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle'); + IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2'); + Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile'); + Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2'); + IcmpHelper4 := assigned(IcmpCreateFile) + and assigned(IcmpCloseHandle) + and assigned(IcmpSendEcho2); + IcmpHelper6 := assigned(Icmp6CreateFile) + and assigned(Icmp6SendEcho2); + end; +end; + +finalization +begin + FreeLibrary(IcmpDllHandle); +end; +{$ENDIF} + +end. diff --git a/pop3send.pas b/pop3send.pas new file mode 100644 index 0000000..d0e5a81 --- /dev/null +++ b/pop3send.pas @@ -0,0 +1,483 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.006.002 | +|==============================================================================| +| Content: POP3 client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(POP3 protocol client) + +Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$M+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit pop3send; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synacode; + +const + cPop3Protocol = '110'; + +type + + {:The three types of possible authorization methods for "logging in" to a POP3 + server.} + TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); + + {:@abstract(Implementation of POP3 client protocol.) + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TPOP3Send = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FStatCount: Integer; + FStatSize: Integer; + FListSize: Integer; + FTimeStamp: string; + FAuthType: TPOP3AuthType; + FPOP3cap: TStringList; + FAutoTLS: Boolean; + FFullSSL: Boolean; + function ReadResult(Full: Boolean): Integer; + function Connect: Boolean; + function AuthLogin: Boolean; + function AuthApop: Boolean; + public + constructor Create; + destructor Destroy; override; + + {:You can call any custom by this method. Call Command without trailing CRLF. + If MultiLine parameter is @true, multilined response are expected. + Result is @true on sucess.} + function CustomCommand(const Command: string; MultiLine: Boolean): boolean; + + {:Call CAPA command for get POP3 server capabilites. + note: not all servers support this command!} + function Capability: Boolean; + + {:Connect to remote POP3 host. If all OK, result is @true.} + function Login: Boolean; + + {:Disconnects from POP3 server.} + function Logout: Boolean; + + {:Send RSET command. If all OK, result is @true.} + function Reset: Boolean; + + {:Send NOOP command. If all OK, result is @true.} + function NoOp: Boolean; + + {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. + If all OK, result is @true.} + function Stat: Boolean; + + {:Send LIST command. If Value is 0, LIST is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} + function List(Value: Integer): Boolean; + + {:Send RETR command. After successful operation dowloaded message in + @link(FullResult). If all OK, result is @true.} + function Retr(Value: Integer): Boolean; + + {:Send RETR command. After successful operation dowloaded message in + @link(Stream). If all OK, result is @true.} + function RetrStream(Value: Integer; Stream: TStream): Boolean; + + {:Send DELE command for delete specified message. If all OK, result is @true.} + function Dele(Value: Integer): Boolean; + + {:Send TOP command. After successful operation dowloaded headers of message + and maxlines count of message in @link(FullResult). If all OK, result is + @true.} + function Top(Value, Maxlines: Integer): Boolean; + + {:Send UIDL command. If Value is 0, UIDL is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} + function Uidl(Value: Integer): Boolean; + + {:Call STLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:Try to find given capabily in capabilty string returned from POP3 server + by CAPA command.} + function FindCap(const Value: string): string; + published + {:Result code of last POP3 operation. 0 - error, 1 - OK.} + property ResultCode: Integer read FResultCode; + + {:Result string of last POP3 operation.} + property ResultString: string read FResultString; + + {:Stringlist with full lines returned as result of POP3 operation. I.e. if + operation is LIST, this property is filled by list of messages. If + operation is RETR, this property have downloaded message.} + property FullResult: TStringList read FFullResult; + + {:After STAT command is there count of messages in inbox.} + property StatCount: Integer read FStatCount; + + {:After STAT command is there size of all messages in inbox.} + property StatSize: Integer read FStatSize; + + {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} + property ListSize: Integer read FListSize; + + {:If server support this, after comnnect is in this property timestamp of + remote server.} + property TimeStamp: string read FTimeStamp; + + {:Type of authorisation for login to POP3 server. Dafault is autodetect one + of possible authorisation. Autodetect do this: + + If remote POP3 server support APOP, try login by APOP method. If APOP is + not supported, or if APOP login failed, try classic USER+PASS login method.} + property AuthType: TPOP3AuthType read FAuthType Write FAuthType; + + {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + end; + +implementation + +constructor TPOP3Send.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FPOP3cap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := true; + FTimeout := 60000; + FTargetPort := cPop3Protocol; + FStatCount := 0; + FStatSize := 0; + FListSize := 0; + FAuthType := POP3AuthAll; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TPOP3Send.Destroy; +begin + FSock.Free; + FPOP3cap.Free; + FullResult.Free; + inherited Destroy; +end; + +function TPOP3Send.ReadResult(Full: Boolean): Integer; +var + s: string; +begin + Result := 0; + FFullResult.Clear; + s := FSock.RecvString(FTimeout); + if Pos('+OK', s) = 1 then + Result := 1; + FResultString := s; + if Full and (Result = 1) then + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + Break; + if s <> '' then + if s[1] = '.' then + Delete(s, 1, 1); + FFullResult.Add(s); + until FSock.LastError <> 0; + if not Full and (Result = 1) then + FFullResult.Add(SeparateRight(FResultString, ' ')); + if FSock.LastError <> 0 then + Result := 0; + FResultCode := Result; +end; + +function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; +begin + FSock.SendString(Command + CRLF); + Result := ReadResult(MultiLine) <> 0; +end; + +function TPOP3Send.AuthLogin: Boolean; +begin + Result := False; + if not CustomCommand('USER ' + FUserName, False) then + exit; + Result := CustomCommand('PASS ' + FPassword, False) +end; + +function TPOP3Send.AuthAPOP: Boolean; +var + s: string; +begin + s := StrToHex(MD5(FTimeStamp + FPassWord)); + Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); +end; + +function TPOP3Send.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FStatCount := 0; + FStatSize := 0; + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TPOP3Send.Capability: Boolean; +begin + FPOP3cap.Clear; + Result := CustomCommand('CAPA', True); + if Result then + FPOP3cap.AddStrings(FFullResult); +end; + +function TPOP3Send.Login: Boolean; +var + s, s1: string; +begin + Result := False; + FTimeStamp := ''; + if not Connect then + Exit; + if ReadResult(False) <> 1 then + Exit; + s := SeparateRight(FResultString, '<'); + if s <> FResultString then + begin + s1 := Trim(SeparateLeft(s, '>')); + if s1 <> s then + FTimeStamp := '<' + s1 + '>'; + end; + Result := False; + if Capability then + if FAutoTLS and (Findcap('STLS') <> '') then + if StartTLS then + Capability + else + begin + Result := False; + Exit; + end; + if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then + begin + Result := AuthApop; + if not Result then + begin + if not Connect then + Exit; + if ReadResult(False) <> 1 then + Exit; + end; + end; + if not Result and not (FAuthType = POP3AuthAPOP) then + Result := AuthLogin; +end; + +function TPOP3Send.Logout: Boolean; +begin + Result := CustomCommand('QUIT', False); + FSock.CloseSocket; +end; + +function TPOP3Send.Reset: Boolean; +begin + Result := CustomCommand('RSET', False); +end; + +function TPOP3Send.NoOp: Boolean; +begin + Result := CustomCommand('NOOP', False); +end; + +function TPOP3Send.Stat: Boolean; +var + s: string; +begin + Result := CustomCommand('STAT', False); + if Result then + begin + s := SeparateRight(ResultString, '+OK '); + FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); + FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); + end; +end; + +function TPOP3Send.List(Value: Integer): Boolean; +var + s: string; + n: integer; +begin + if Value = 0 then + s := 'LIST' + else + s := 'LIST ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); + FListSize := 0; + if Result then + if Value <> 0 then + begin + s := SeparateRight(ResultString, '+OK '); + FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); + end + else + for n := 0 to FFullResult.Count - 1 do + FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); +end; + +function TPOP3Send.Retr(Value: Integer): Boolean; +begin + Result := CustomCommand('RETR ' + IntToStr(Value), True); +end; + +//based on code by Miha Vrhovnik +function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; +var + s: string; +begin + Result := False; + FFullResult.Clear; + Stream.Size := 0; + FSock.SendString('RETR ' + IntToStr(Value) + CRLF); + + s := FSock.RecvString(FTimeout); + if Pos('+OK', s) = 1 then + Result := True; + FResultString := s; + if Result then begin + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + Break; + if s <> '' then begin + if s[1] = '.' then + Delete(s, 1, 1); + end; + WriteStrToStream(Stream, s); + WriteStrToStream(Stream, CRLF); + until FSock.LastError <> 0; + end; + + if Result then + FResultCode := 1 + else + FResultCode := 0; +end; + +function TPOP3Send.Dele(Value: Integer): Boolean; +begin + Result := CustomCommand('DELE ' + IntToStr(Value), False); +end; + +function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; +begin + Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); +end; + +function TPOP3Send.Uidl(Value: Integer): Boolean; +var + s: string; +begin + if Value = 0 then + s := 'UIDL' + else + s := 'UIDL ' + IntToStr(Value); + Result := CustomCommand(s, Value = 0); +end; + +function TPOP3Send.StartTLS: Boolean; +begin + Result := False; + if CustomCommand('STLS', False) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +function TPOP3Send.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FPOP3cap.Count - 1 do + if Pos(s, UpperCase(FPOP3cap[n])) = 1 then + begin + Result := FPOP3cap[n]; + Break; + end; +end; + +end. diff --git a/slogsend.pas b/slogsend.pas new file mode 100644 index 0000000..e9ba387 --- /dev/null +++ b/slogsend.pas @@ -0,0 +1,320 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.003 | +|==============================================================================| +| Content: SysLog client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Christian Brosius | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(BSD SYSLOG protocol) + +Used RFC: RFC-3164 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit slogsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cSysLogProtocol = '514'; + + FCL_Kernel = 0; + FCL_UserLevel = 1; + FCL_MailSystem = 2; + FCL_System = 3; + FCL_Security = 4; + FCL_Syslogd = 5; + FCL_Printer = 6; + FCL_News = 7; + FCL_UUCP = 8; + FCL_Clock = 9; + FCL_Authorization = 10; + FCL_FTP = 11; + FCL_NTP = 12; + FCL_LogAudit = 13; + FCL_LogAlert = 14; + FCL_Time = 15; + FCL_Local0 = 16; + FCL_Local1 = 17; + FCL_Local2 = 18; + FCL_Local3 = 19; + FCL_Local4 = 20; + FCL_Local5 = 21; + FCL_Local6 = 22; + FCL_Local7 = 23; + +type + {:@abstract(Define possible priority of Syslog message)} + TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, + Debug); + + {:@abstract(encoding or decoding of SYSLOG message)} + TSyslogMessage = class(TObject) + private + FFacility:Byte; + FSeverity:TSyslogSeverity; + FDateTime:TDateTime; + FTag:String; + FMessage:String; + FLocalIP:String; + function GetPacketBuf:String; + procedure SetPacketBuf(Value:String); + public + {:Reset values to defaults} + procedure Clear; + published + {:Define facilicity of Syslog message. For specify you may use predefined + FCL_* constants. Default is "FCL_Local0".} + property Facility:Byte read FFacility write FFacility; + + {:Define possible priority of Syslog message. Default is "Debug".} + property Severity:TSyslogSeverity read FSeverity write FSeverity; + + {:date and time of Syslog message} + property DateTime:TDateTime read FDateTime write FDateTime; + + {:This is used for identify process of this message. Default is filename + of your executable file.} + property Tag:String read FTag write FTag; + + {:Text of your message for log.} + property LogMessage:String read FMessage write FMessage; + + {:IP address of message sender.} + property LocalIP:String read FLocalIP write FLocalIP; + + {:This property holds encoded binary SYSLOG packet} + property PacketBuf:String read GetPacketBuf write SetPacketBuf; + end; + + {:@abstract(This object implement BSD SysLog client) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSyslogSend = class(TSynaClient) + private + FSock: TUDPBlockSocket; + FSysLogMessage: TSysLogMessage; + public + constructor Create; + destructor Destroy; override; + {:Send Syslog UDP packet defined by @link(SysLogMessage).} + function DoIt: Boolean; + published + {:Syslog message for send} + property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; + end; + +{:Simply send packet to specified Syslog server.} +function ToSysLog(const SyslogServer: string; Facil: Byte; + Sever: TSyslogSeverity; const Content: string): Boolean; + +implementation + +function TSyslogMessage.GetPacketBuf:String; +begin + Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; + Result := Result + CDateTime(FDateTime) + ' '; + Result := Result + FLocalIP + ' '; + Result := Result + FTag + ': ' + FMessage; +end; + +procedure TSyslogMessage.SetPacketBuf(Value:String); +var StrBuf:String; + IntBuf,Pos:Integer; +begin + if Length(Value) < 1 then exit; + Pos := 1; + if Value[Pos] <> '<' then exit; + Inc(Pos); + // Facility and Severity + StrBuf := ''; + while (Value[Pos] <> '>')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + IntBuf := StrToInt(StrBuf); + FFacility := IntBuf div 8; + case (IntBuf mod 8)of + 0:FSeverity := Emergency; + 1:FSeverity := Alert; + 2:FSeverity := Critical; + 3:FSeverity := Error; + 4:FSeverity := Warning; + 5:FSeverity := Notice; + 6:FSeverity := Info; + 7:FSeverity := Debug; + end; + // DateTime + Inc(Pos); + StrBuf := ''; + // Month + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Day + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Time + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FDateTime := DecodeRFCDateTime(StrBuf); + Inc(Pos); + + // LocalIP + StrBuf := ''; + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FLocalIP := StrBuf; + Inc(Pos); + // Tag + StrBuf := ''; + while (Value[Pos] <> ':')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FTag := StrBuf; + // LogMessage + Inc(Pos); + StrBuf := ''; + while (Pos <= Length(Value))do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FMessage := TrimSP(StrBuf); +end; + +procedure TSysLogMessage.Clear; +begin + FFacility := FCL_Local0; + FSeverity := Debug; + FTag := ExtractFileName(ParamStr(0)); + FMessage := ''; + FLocalIP := '0.0.0.0'; +end; + +//------------------------------------------------------------------------------ + +constructor TSyslogSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FSysLogMessage := TSysLogMessage.Create; + FTargetPort := cSysLogProtocol; +end; + +destructor TSyslogSend.Destroy; +begin + FSock.Free; + FSysLogMessage.Free; + inherited Destroy; +end; + +function TSyslogSend.DoIt: Boolean; +var + L: TStringList; +begin + Result := False; + L := TStringList.Create; + try + FSock.ResolveNameToIP(FSock.Localname, L); + if L.Count < 1 then + FSysLogMessage.LocalIP := '0.0.0.0' + else + FSysLogMessage.LocalIP := L[0]; + finally + L.Free; + end; + FSysLogMessage.DateTime := Now; + if Length(FSysLogMessage.PacketBuf) <= 1024 then + begin + FSock.Connect(FTargetHost, FTargetPort); + FSock.SendString(FSysLogMessage.PacketBuf); + Result := FSock.LastError = 0; + end; +end; + +{==============================================================================} + +function ToSysLog(const SyslogServer: string; Facil: Byte; + Sever: TSyslogSeverity; const Content: string): Boolean; +begin + with TSyslogSend.Create do + try + TargetHost :=SyslogServer; + SysLogMessage.Facility := Facil; + SysLogMessage.Severity := Sever; + SysLogMessage.LogMessage := Content; + Result := DoIt; + finally + Free; + end; +end; + +end. diff --git a/smtpsend.pas b/smtpsend.pas new file mode 100644 index 0000000..f3b5d09 --- /dev/null +++ b/smtpsend.pas @@ -0,0 +1,987 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.005.001 | +|==============================================================================| +| Content: SMTP client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SMTP client) + +Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, + RFC-2554, RFC-2821 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit smtpsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil, synacode; + +const + cSmtpProtocol = '25'; + +type + TOnAnswerEvent = TNotifyEvent; + + {:@abstract(Implementation of SMTP and ESMTP procotol), + include some ESMTP extensions, include SSL/TLS too. + + Note: Are you missing properties for setting Username and Password for ESMTP? + Look to parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSMTPSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + //--- + FOnAnswerEvent: TOnAnswerEvent; + FLastCmd: string; + FLastCmdData: string; + //--- + FResultCode: Integer; + FResultString: string; + FFullResult: TStringList; + FESMTPcap: TStringList; + FESMTP: Boolean; + FAuthDone: Boolean; + FESMTPSize: Boolean; + FMaxSize: Integer; + FEnhCode1: Integer; + FEnhCode2: Integer; + FEnhCode3: Integer; + FSystemName: string; + FAutoTLS: Boolean; + FFullSSL: Boolean; + procedure EnhancedCode(const Value: string); + function ReadResult: Integer; + function AuthLogin: Boolean; + function AuthCram: Boolean; + function AuthPlain: Boolean; + function Helo: Boolean; + function Ehlo: Boolean; + function Connect: Boolean; + procedure DoAnswerEvent; + public + constructor Create; + destructor Destroy; override; + + function SendCmd(const AOut: string; const AResponse: SmallInt = -1): SmallInt; overload; + function SendCmd(const AOut: string; const AResponse: array of SmallInt): SmallInt; overload; + + //--- + procedure ClearResult; + procedure ParseESmtp; + procedure RaiseProtocolExcept; + function SmtpSendCmd(const ACmd: string; const ACmdData: string = ''): Integer; + function SmtpSendCmdHelo: Boolean; + function SmtpSendCmdEhlo: Boolean; + function SmtpSendCmdFrom(const AFromMail: string; const ADop: string = ''): Boolean; + function SmtpSendCmdRcpt(const ARcptMail: string; const ADop: string = ''): Boolean; + function SmtpSendCmdData: Boolean; + function SmtpSendMailData(AEml: TStrings): Boolean; + function SmtpSendQuit: Boolean; + {Ðàçäåëåíèå Login() íà îòäåëüíûå øàãè} + function SmtpConnect: Boolean; + function SmtpHelo: Boolean; + function SmtpLogin: Boolean; + function SmtpStartTLS: Boolean; + function SmtpAfterHelo: Boolean; + //--- + + {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and + begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses + ESMTP capabilites and if you specified Username and password and remote + server can handle AUTH command, try login by AUTH command. Preffered login + method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is + @false.} + function Login: Boolean; + + {:Close SMTP session (QUIT command) and disconnect from SMTP server.} + function Logout: Boolean; + + {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true, + else result is @false.} + function Reset: Boolean; + + {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true, + else result is @false.} + function NoOp: Boolean; + + {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's + e-mail address is empty string, transmited message is error message. + + If size not 0 and remote server can handle SIZE parameter, append SIZE + parameter to request. If all OK, result is @true, else result is @false.} + function MailFrom(const Value, ADop: string; Size: Integer = 0): Boolean; + + {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an + empty string. If all OK, result is @true, else result is @false.} + function MailTo(const Value: string): Boolean; + + {:Send DATA SMTP command and transmit message data. If all OK, result is + @true, else result is @false.} + function MailData(const Value: Tstrings): Boolean; + + {:Send ETRN SMTP command for start sending of remote queue for domain in + Value. If all OK, result is @true, else result is @false.} + function Etrn(const Value: string): Boolean; + + {:Send VRFY SMTP command for check receiver e-mail address. It cannot be + an empty string. If all OK, result is @true, else result is @false.} + function Verify(const Value: string): Boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} + function StartTLS: Boolean; + + {:Return string descriptive text for enhanced result codes stored in + @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).} + function EnhCodeString: string; + + {:Try to find specified capability in ESMTP response.} + function FindCap(const Value: string): string; + + //--- + property LastCmd: string read FLastCmd; + property LastCmdData: string read FLastCmdData; + property OnAnswer: TOnAnswerEvent read FOnAnswerEvent write FOnAnswerEvent; + //--- + + published + {:result code of last SMTP command.} + property ResultCode: Integer read FResultCode; + + {:result string of last SMTP command (begin with string representation of + result code).} + property ResultString: string read FResultString; + + {:All result strings of last SMTP command (result is maybe multiline!).} + property FullResult: TStringList read FFullResult; + + {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP + server only!).} + property ESMTPcap: TStringList read FESMTPcap; + + {:@TRUE if you successfuly logged to ESMTP server.} + property ESMTP: Boolean read FESMTP; + + {:@TRUE if you successfuly pass authorisation to remote server.} + property AuthDone: Boolean read FAuthDone; + + {:@TRUE if remote server can handle SIZE parameter.} + property ESMTPSize: Boolean read FESMTPSize; + + {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote + server can handle.} + property MaxSize: Integer read FMaxSize; + + {:First digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode1: Integer read FEnhCode1; + + {:Second digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode2: Integer read FEnhCode2; + + {:Third digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} + property EnhCode3: Integer read FEnhCode3; + + {:name of our system used in HELO and EHLO command. Implicit value is + internet address of your machine.} + property SystemName: string read FSystemName Write FSystemName; + + {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} + property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} + property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + end; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send maildata (text of e-mail with all SMTP headers! For example when + text of message is created by @link(TMimemess) object) from "MailFrom" e-mail + address to "MailTo" e-mail address (If you need more then one receiver, then + separate their addresses by comma). + + Function sends e-mail to a SMTP server defined in "SMTPhost" parameter. + Username and password are used for authorization to the "SMTPhost". If you + don't want authorization, set "Username" and "Password" to empty strings. If + e-mail message is successfully sent, the result returns @true. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendToRaw(const MailFrom, MailTo, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send "Maildata" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you + need more then one receiver, then separate their addresses by comma). + + This function constructs all needed SMTP headers (with DATE header) and sends + the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the + e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Sends "MailData" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one + receiver, then separate their addresses by comma). + + This function sends the e-mail to the SMTP server defined in the "SMTPhost" + parameter. Username and password are used for authorization to the "SMTPhost". + If you dont want authorization, set "Username" and "Password" to empty Strings. + If the e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} +function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; + +implementation + +constructor TSMTPSend.Create; +begin + inherited Create; + FFullResult := TStringList.Create; + FESMTPcap := TStringList.Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.ConvertLineEnd := true; + FTimeout := 60000; + FTargetPort := cSmtpProtocol; + FSystemName := FSock.LocalName; + FAutoTLS := False; + FFullSSL := False; +end; + +destructor TSMTPSend.Destroy; +begin + FSock.Free; + FESMTPcap.Free; + FFullResult.Free; + inherited Destroy; +end; + +procedure TSMTPSend.DoAnswerEvent; +begin + if Assigned(FOnAnswerEvent) then + FOnAnswerEvent(Self) +end; + +procedure TSMTPSend.EnhancedCode(const Value: string); +var + s, t: string; + e1, e2, e3: Integer; +begin + FEnhCode1 := 0; + FEnhCode2 := 0; + FEnhCode3 := 0; + s := Copy(Value, 5, Length(Value) - 4); + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); + if t = '' then + Exit; + if Length(t) > 1 then + Exit; + e1 := StrToIntDef(t, 0); + if e1 = 0 then + Exit; + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); + if t = '' then + Exit; + if Length(t) > 3 then + Exit; + e2 := StrToIntDef(t, 0); + t := Trim(SeparateLeft(s, ' ')); + if t = '' then + Exit; + if Length(t) > 3 then + Exit; + e3 := StrToIntDef(t, 0); + FEnhCode1 := e1; + FEnhCode2 := e2; + FEnhCode3 := e3; +end; + +procedure TSMTPSend.RaiseProtocolExcept; +begin + raise ESynProtocolError.CreateErrorCode(FResultCode, FFullResult.Text); +end; + +function TSMTPSend.ReadResult: Integer; +var + s: String; +begin + Result := 0; + FFullResult.Clear; + repeat + s := FSock.RecvString(FTimeout); + if FResultString = '' then + FResultString := s + else + FResultString := FResultString + #13#10 + s; + FFullResult.Add(s); + if FSock.LastError <> 0 then + Break; + until Pos('-', s) <> 4; + s := FFullResult[0]; + if Length(s) >= 3 then + Result := StrToIntDef(Copy(s, 1, 3), 0); + FResultCode := Result; + EnhancedCode(s); + DoAnswerEvent; +end; + +function TSMTPSend.AuthLogin: Boolean; +begin + Result := False; + FSock.SendString('AUTH LOGIN' + CRLF); + if ReadResult <> 334 then + Exit; + FSock.SendString(EncodeBase64(FUsername) + CRLF); + if ReadResult <> 334 then + Exit; + FSock.SendString(EncodeBase64(FPassword) + CRLF); + Result := ReadResult = 235; +end; + +function TSMTPSend.AuthCram: Boolean; +var + s: ansistring; +begin + Result := False; + FSock.SendString('AUTH CRAM-MD5' + CRLF); + if ReadResult <> 334 then + Exit; + s := Copy(FResultString, 5, Length(FResultString) - 4); + s := DecodeBase64(s); + s := HMAC_MD5(s, FPassword); + s := FUsername + ' ' + StrToHex(s); + FSock.SendString(EncodeBase64(s) + CRLF); + Result := ReadResult = 235; +end; + +function TSMTPSend.AuthPlain: Boolean; +var + s: ansistring; +begin + s := ansichar(0) + FUsername + ansichar(0) + FPassword; + FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF); + Result := ReadResult = 235; +end; + +procedure TSMTPSend.ClearResult; +begin + FResultCode := -1; + FResultString := ''; + FFullResult.Clear; + //--- + FLastCmd := ''; + FLastCmdData := ''; +end; + +function TSMTPSend.Connect: Boolean; +begin + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError = 0 then + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError = 0 then + if FFullSSL then + FSock.SSLDoConnect; + Result := FSock.LastError = 0; +end; + +function TSMTPSend.Helo: Boolean; +var + x: Integer; +begin + FSock.SendString('HELO ' + FSystemName + CRLF); + x := ReadResult; + Result := ((x >= 250) and (x <= 259)) or (x = 220); +end; + +function TSMTPSend.Ehlo: Boolean; +var + x: Integer; +begin + FSock.SendString('EHLO ' + FSystemName + CRLF); + x := ReadResult; + Result := ((x >= 250) and (x <= 259)) or (x = 220); +end; + +function TSMTPSend.Login: Boolean; +var + n: Integer; + auths: string; + s: string; +begin + Result := False; +//------------------------------- + FResultCode := -1; + FResultString := ''; + FFullResult.Clear; +//------------------------------- + FESMTP := True; + FAuthDone := False; + FESMTPcap.clear; + FESMTPSize := False; + FMaxSize := 0; + if not Connect then + Exit; + if ReadResult <> 220 then + Exit; + if not Ehlo then + begin + FESMTP := False; + if not Helo then + Exit; + end; + Result := True; + if FESMTP then + begin + for n := 1 to FFullResult.Count - 1 do + FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then + if StartTLS then + begin + Ehlo; + FESMTPcap.Clear; + for n := 1 to FFullResult.Count - 1 do + FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + end + else + begin + Result := False; + Exit; + end; + if not ((FUsername = '') and (FPassword = '')) then + begin + s := FindCap('AUTH '); + if s = '' then + s := FindCap('AUTH='); + auths := UpperCase(s); + if s <> '' then + begin + if Pos('CRAM-MD5', auths) > 0 then + FAuthDone := AuthCram; + if (not FauthDone) and (Pos('PLAIN', auths) > 0) then + FAuthDone := AuthPlain; + if (not FauthDone) and (Pos('LOGIN', auths) > 0) then + FAuthDone := AuthLogin; + end; + end; + s := FindCap('SIZE'); + if s <> '' then + begin + FESMTPsize := True; + FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0); + end; + end; +end; + +function TSMTPSend.Logout: Boolean; +begin + FSock.SendString('QUIT' + CRLF); + Result := ReadResult = 221; + FSock.CloseSocket; +end; + +function TSMTPSend.Reset: Boolean; +begin + FSock.SendString('RSET' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.NoOp: Boolean; +begin + FSock.SendString('NOOP' + CRLF); + Result := ReadResult div 100 = 2; +end; + +procedure TSMTPSend.ParseESmtp; +var + n: Integer; + z: string; +begin + FESMTPcap.Clear; + if ESMTP then + for n := 1 to FFullResult.Count - 1 do + begin + z := FFullResult[n]; + FESMTPcap.Add(Copy(z, 5, MaxInt)); + end; +end; + +function TSMTPSend.MailFrom(const Value, ADop: string; Size: Integer): Boolean; +var + s: string; +begin + s := 'MAIL FROM: <' + Value + '>'; + if FESMTPsize and (Size > 0) then + s := s + ' SIZE=' + IntToStr(Size); + if ADop <> '' then + s := s + ' ' + ADop; + FSock.SendString(s + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.MailTo(const Value: string): Boolean; +begin + FSock.SendString('RCPT TO: <' + Value + '>' + CRLF); + Result := ReadResult = 250; +end; + +function TSMTPSend.MailData(const Value: TStrings): Boolean; +var + n: Integer; + s: string; + t: string; + x: integer; +begin + Result := False; + FSock.SendString('DATA' + CRLF); + if ReadResult <> 354 then + Exit; + t := ''; + x := 1500; + for n := 0 to Value.Count - 1 do + begin + s := Value[n]; + if Length(s) >= 1 then + if s[1] = '.' then + s := '.' + s; + if Length(t) + Length(s) >= x then + begin + FSock.SendString(t); + t := ''; + end; + t := t + s + CRLF; + end; + if t <> '' then + FSock.SendString(t); + FSock.SendString('.' + CRLF); + Result := ReadResult div 100 = 2; +end; + +function TSMTPSend.Etrn(const Value: string): Boolean; +var + x: Integer; +begin + FSock.SendString('ETRN ' + Value + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.Verify(const Value: string): Boolean; +var + x: Integer; +begin + FSock.SendString('VRFY ' + Value + CRLF); + x := ReadResult; + Result := (x >= 250) and (x <= 259); +end; + +function TSMTPSend.SendCmd(const AOut: string; + const AResponse: SmallInt): SmallInt; +begin + if AResponse = -1 then begin + Result := SendCmd(AOut, []); + end else begin + Result := SendCmd(AOut, [AResponse]); + end; +end; + +function TSMTPSend.SendCmd(const AOut: string; + const AResponse: array of SmallInt): SmallInt; +var + j : Integer; +begin + FSock.SendString(AOut + CRLF); + Result := ReadResult; + if Length(AResponse)>0 then + begin + for j:=Low(AResponse) to High(AResponse) do + begin + if AResponse[j]=ResultCode then + Exit; + end; + RaiseProtocolExcept; + end; +end; + +function TSMTPSend.SmtpConnect: Boolean; +begin + Result := False; + ClearResult; + FESMTP := False; + FAuthDone := False; + FESMTPcap.Clear; + FESMTPSize := False; + FMaxSize := 0; + if not Connect then + Exit; + if ReadResult <> 220 then + Exit; + Result := True; +end; + +function TSMTPSend.SmtpHelo: Boolean; +begin + ClearResult; + Result := False; + if SmtpSendCmdEhlo then + begin + FESMTP := True; + Result := True; + end + else + begin + if SmtpSendCmdHelo then + Result := True; + end; +end; + +function TSMTPSend.SmtpLogin: Boolean; +var s, auths: AnsiString; +begin + ClearResult; + s := FindCap('AUTH '); + if s = '' then + s := FindCap('AUTH='); + auths := UpperCase(s); + if s <> '' then + begin + if Pos('CRAM-MD5', auths) > 0 then + FAuthDone := AuthCram; + if (not FauthDone) and (Pos('PLAIN', auths) > 0) then + FAuthDone := AuthPlain; + if (not FauthDone) and (Pos('LOGIN', auths) > 0) then + FAuthDone := AuthLogin; + end; + Result := FAuthDone; +end; + +function TSMTPSend.SmtpSendCmd(const ACmd, ACmdData: string): Integer; +var lCmd: AnsiString; +begin + ClearResult; + FLastCmd := ACmd; + FLastCmdData:= ACmdData; + if ACmdData='' then + lCmd := ACmd + else + lCmd := ACmd + ' ' + ACmdData; + Result := SendCmd(lCmd, []); +end; + +function TSMTPSend.SmtpSendCmdEhlo: Boolean; +var x: Integer; +begin + x := SmtpSendCmd('EHLO', FSystemName); + Result := ((x >= 250) and (x <= 259)) or (x = 220); +end; + +function TSMTPSend.SmtpSendCmdHelo: Boolean; +var x: Integer; +begin + x := SmtpSendCmd('HELO', FSystemName); + Result := ((x >= 250) and (x <= 259)) or (x = 220); +end; + +function TSMTPSend.SmtpSendCmdFrom(const AFromMail, ADop: string): Boolean; +var z: AnsiString; +begin + if ADop='' then z := '<' + AFromMail + '>' + else z := '<' + AFromMail + '> ' + ADop; + Result := SmtpSendCmd('MAIL FROM:', z) = 250 +end; + +function TSMTPSend.SmtpSendCmdRcpt(const ARcptMail, ADop: string): Boolean; +var z: AnsiString; +begin + if ADop='' then z := '<' + ARcptMail + '>' + else z := '<' + ARcptMail + '> ' + ADop; + Result := SmtpSendCmd('RCPT TO:', z) = 250 +end; + +function TSMTPSend.SmtpSendCmdData: Boolean; +begin + Result := SmtpSendCmd('DATA') = 354; +end; + +function TSMTPSend.SmtpSendMailData(AEml: TStrings): Boolean; +var + j: Integer; + z: AnsiString; +begin + for j:=0 to (AEml.Count-1) do + begin + z := AnsiString(AEml[j]); + if z='.' then + z := '..'; + Sock.SendString(z+CRLF); + end; + Result := SmtpSendCmd('.') = 250 +end; + +function TSMTPSend.SmtpSendQuit: Boolean; +begin + Result := SmtpSendCmd('QUIT') = 221 +end; + +function TSMTPSend.SmtpStartTLS: Boolean; +var lres: Integer; +begin + lres := SmtpSendCmd('STARTTLS'); + if (lres = 220) and (FSock.LastError = 0) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end + else + begin + Result := False + end; +end; + +function TSMTPSend.SmtpAfterHelo: Boolean; +var s: AnsiString; +begin + Result := True; + if FESMTP then + begin + s := FindCap('SIZE'); + if s <> '' then + begin + FESMTPsize := True; + FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0); + end; + end; +end; + + +function TSMTPSend.StartTLS: Boolean; +begin + Result := False; + if FindCap('STARTTLS') <> '' then + begin + FSock.SendString('STARTTLS' + CRLF); + if (ReadResult = 220) and (FSock.LastError = 0) then + begin + Fsock.SSLDoConnect; + Result := FSock.LastError = 0; + end; + end; +end; + +function TSMTPSend.EnhCodeString: string; +var + s, t: string; +begin + s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3); + t := ''; + if s = '0.0' then t := 'Other undefined Status'; + if s = '1.0' then t := 'Other address status'; + if s = '1.1' then t := 'Bad destination mailbox address'; + if s = '1.2' then t := 'Bad destination system address'; + if s = '1.3' then t := 'Bad destination mailbox address syntax'; + if s = '1.4' then t := 'Destination mailbox address ambiguous'; + if s = '1.5' then t := 'Destination mailbox address valid'; + if s = '1.6' then t := 'Mailbox has moved'; + if s = '1.7' then t := 'Bad sender''s mailbox address syntax'; + if s = '1.8' then t := 'Bad sender''s system address'; + if s = '2.0' then t := 'Other or undefined mailbox status'; + if s = '2.1' then t := 'Mailbox disabled, not accepting messages'; + if s = '2.2' then t := 'Mailbox full'; + if s = '2.3' then t := 'Message Length exceeds administrative limit'; + if s = '2.4' then t := 'Mailing list expansion problem'; + if s = '3.0' then t := 'Other or undefined mail system status'; + if s = '3.1' then t := 'Mail system full'; + if s = '3.2' then t := 'System not accepting network messages'; + if s = '3.3' then t := 'System not capable of selected features'; + if s = '3.4' then t := 'Message too big for system'; + if s = '3.5' then t := 'System incorrectly configured'; + if s = '4.0' then t := 'Other or undefined network or routing status'; + if s = '4.1' then t := 'No answer from host'; + if s = '4.2' then t := 'Bad connection'; + if s = '4.3' then t := 'Routing server failure'; + if s = '4.4' then t := 'Unable to route'; + if s = '4.5' then t := 'Network congestion'; + if s = '4.6' then t := 'Routing loop detected'; + if s = '4.7' then t := 'Delivery time expired'; + if s = '5.0' then t := 'Other or undefined protocol status'; + if s = '5.1' then t := 'Invalid command'; + if s = '5.2' then t := 'Syntax error'; + if s = '5.3' then t := 'Too many recipients'; + if s = '5.4' then t := 'Invalid command arguments'; + if s = '5.5' then t := 'Wrong protocol version'; + if s = '6.0' then t := 'Other or undefined media error'; + if s = '6.1' then t := 'Media not supported'; + if s = '6.2' then t := 'Conversion required and prohibited'; + if s = '6.3' then t := 'Conversion required but not supported'; + if s = '6.4' then t := 'Conversion with loss performed'; + if s = '6.5' then t := 'Conversion failed'; + if s = '7.0' then t := 'Other or undefined security status'; + if s = '7.1' then t := 'Delivery not authorized, message refused'; + if s = '7.2' then t := 'Mailing list expansion prohibited'; + if s = '7.3' then t := 'Security conversion required but not possible'; + if s = '7.4' then t := 'Security features not supported'; + if s = '7.5' then t := 'Cryptographic failure'; + if s = '7.6' then t := 'Cryptographic algorithm not supported'; + if s = '7.7' then t := 'Message integrity failure'; + s := '???-'; + if FEnhCode1 = 2 then s := 'Success-'; + if FEnhCode1 = 4 then s := 'Persistent Transient Failure-'; + if FEnhCode1 = 5 then s := 'Permanent Failure-'; + Result := s + t; +end; + +function TSMTPSend.FindCap(const Value: string): string; +var + n: Integer; + s: string; +begin + s := UpperCase(Value); + Result := ''; + for n := 0 to FESMTPcap.Count - 1 do + if Pos(s, UpperCase(FESMTPcap[n])) = 1 then + begin + Result := FESMTPcap[n]; + Break; + end; +end; + +{==============================================================================} + +function SendToRaw(const MailFrom, MailTo, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; +var + SMTP: TSMTPSend; + s, t: string; +begin + Result := False; + SMTP := TSMTPSend.Create; + try +// if you need SOCKS5 support, uncomment next lines: + // SMTP.Sock.SocksIP := '127.0.0.1'; + // SMTP.Sock.SocksPort := '1080'; +// if you need support for upgrade session to TSL/SSL, uncomment next lines: + SMTP.AutoTLS := True; +// if you need support for TSL/SSL tunnel, uncomment next lines: + SMTP.FullSSL := True; + SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':')); + s := Trim(SeparateRight(SMTPHost, ':')); + if (s <> '') and (s <> SMTPHost) then + SMTP.TargetPort := s; + SMTP.Username := Username; + SMTP.Password := Password; + if SMTP.Login then + begin + if SMTP.MailFrom(GetEmailAddr(MailFrom), '', Length(MailData.Text)) then + begin + s := MailTo; + repeat + t := GetEmailAddr(Trim(FetchEx(s, ',', '"'))); + if t <> '' then + Result := SMTP.MailTo(t); + if not Result then + Break; + until s = ''; + if Result then + Result := SMTP.MailData(MailData); + end; + SMTP.Logout; + end; + finally + SMTP.Free; + end; +end; + +function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings; const Username, Password: string): Boolean; +var + t: TStrings; +begin + t := TStringList.Create; + try + t.Assign(MailData); + t.Insert(0, ''); + t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); + t.Insert(0, 'Subject: ' + Subject); + t.Insert(0, 'Date: ' + Rfc822DateTime(now)); + t.Insert(0, 'To: ' + MailTo); + t.Insert(0, 'From: ' + MailFrom); + Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password); + finally + t.Free; + end; +end; + +function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; + const MailData: TStrings): Boolean; +begin + Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', ''); +end; + +end. diff --git a/snmpsend.pas b/snmpsend.pas new file mode 100644 index 0000000..1462c85 --- /dev/null +++ b/snmpsend.pas @@ -0,0 +1,1269 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.000 | +|==============================================================================| +| Content: SNMP client | +|==============================================================================| +| Copyright (c)1999-2011, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Jean-Fabien Connault (cycocrew@worldnet.fr) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SNMP client) +Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization +and privacy encryption. + +Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416, RFC-3826 + +Supported Authorization hashes: MD5, SHA1 +Supported Privacy encryptions: DES, 3DES, AES +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit snmpsend; + +interface + +uses + Classes, SysUtils, + blcksock, synautil, asn1util, synaip, synacode, synacrypt; + +const + cSnmpProtocol = '161'; + cSnmpTrapProtocol = '162'; + + SNMP_V1 = 0; + SNMP_V2C = 1; + SNMP_V3 = 3; + + //PDU type + PDUGetRequest = $A0; + PDUGetNextRequest = $A1; + PDUGetResponse = $A2; + PDUSetRequest = $A3; + PDUTrap = $A4; //Obsolete + //for SNMPv2 + PDUGetBulkRequest = $A5; + PDUInformRequest = $A6; + PDUTrapV2 = $A7; + PDUReport = $A8; + + //errors + ENoError = 0; + ETooBig = 1; + ENoSuchName = 2; + EBadValue = 3; + EReadOnly = 4; + EGenErr = 5; + //errors SNMPv2 + ENoAccess = 6; + EWrongType = 7; + EWrongLength = 8; + EWrongEncoding = 9; + EWrongValue = 10; + ENoCreation = 11; + EInconsistentValue = 12; + EResourceUnavailable = 13; + ECommitFailed = 14; + EUndoFailed = 15; + EAuthorizationError = 16; + ENotWritable = 17; + EInconsistentName = 18; + +type + + {:@abstract(Possible values for SNMPv3 flags.) + This flags specify level of authorization and encryption.} + TV3Flags = ( + NoAuthNoPriv, + AuthNoPriv, + AuthPriv); + + {:@abstract(Type of SNMPv3 authorization)} + TV3Auth = ( + AuthMD5, + AuthSHA1); + + {:@abstract(Type of SNMPv3 privacy)} + TV3Priv = ( + PrivDES, + Priv3DES, + PrivAES); + + {:@abstract(Data object with one record of MIB OID and corresponding values.)} + TSNMPMib = class(TObject) + protected + FOID: AnsiString; + FValue: AnsiString; + FValueType: Integer; + published + {:OID number in string format.} + property OID: AnsiString read FOID write FOID; + + {:Value of OID object in string format.} + property Value: AnsiString read FValue write FValue; + + {:Define type of Value. Supported values are defined in @link(asn1util). + For queries use ASN1_NULL, becouse you don't know type in response!} + property ValueType: Integer read FValueType write FValueType; + end; + + {:@abstract(It holding all information for SNMPv3 agent synchronization) + Used internally.} + TV3Sync = record + EngineID: AnsiString; + EngineBoots: integer; + EngineTime: integer; + EngineStamp: Cardinal; + end; + + {:@abstract(Data object abstracts SNMP data packet)} + TSNMPRec = class(TObject) + protected + FVersion: Integer; + FPDUType: Integer; + FID: Integer; + FErrorStatus: Integer; + FErrorIndex: Integer; + FCommunity: AnsiString; + FSNMPMibList: TList; + FMaxSize: Integer; + FFlags: TV3Flags; + FFlagReportable: Boolean; + FContextEngineID: AnsiString; + FContextName: AnsiString; + FAuthMode: TV3Auth; + FAuthEngineID: AnsiString; + FAuthEngineBoots: integer; + FAuthEngineTime: integer; + FAuthEngineTimeStamp: cardinal; + FUserName: AnsiString; + FPassword: AnsiString; + FAuthKey: AnsiString; + FPrivMode: TV3Priv; + FPrivPassword: AnsiString; + FPrivKey: AnsiString; + FPrivSalt: AnsiString; + FPrivSaltCounter: integer; + FOldTrapEnterprise: AnsiString; + FOldTrapHost: AnsiString; + FOldTrapGen: Integer; + FOldTrapSpec: Integer; + FOldTrapTimeTicks: Integer; + function Pass2Key(const Value: AnsiString): AnsiString; + function EncryptPDU(const value: AnsiString): AnsiString; + function DecryptPDU(const value: AnsiString): AnsiString; + public + constructor Create; + destructor Destroy; override; + + {:Decode SNMP packet in buffer to object properties.} + function DecodeBuf(Buffer: AnsiString): Boolean; + + {:Encode obeject properties to SNMP packet.} + function EncodeBuf: AnsiString; + + {:Clears all object properties to default values.} + procedure Clear; + + {:Add entry to @link(SNMPMibList). For queries use value as empty string, + and ValueType as ASN1_NULL.} + procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); + + {:Delete entry from @link(SNMPMibList).} + procedure MIBDelete(Index: Integer); + + {:Search @link(SNMPMibList) list for MIB and return correspond value.} + function MIBGet(const MIB: AnsiString): AnsiString; + + {:return number of entries in MIB array.} + function MIBCount: integer; + + {:Return MIB information from given row of MIB array.} + function MIBByIndex(Index: Integer): TSNMPMib; + + {:List of @link(TSNMPMib) objects.} + property SNMPMibList: TList read FSNMPMibList; + published + {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use + value 1 for SNMPv2c or value 3 for SNMPv3.} + property Version: Integer read FVersion write FVersion; + + {:Community string for autorize access to SNMP server. (Case sensitive!) + Community string is not used in SNMPv3! Use @link(Username) and + @link(password) instead!} + property Community: AnsiString read FCommunity write FCommunity; + + {:Define type of SNMP operation.} + property PDUType: Integer read FPDUType write FPDUType; + + {:Contains ID number. Not need to use.} + property ID: Integer read FID write FID; + + {:When packet is reply, contains error code. Supported values are defined by + E* constants.} + property ErrorStatus: Integer read FErrorStatus write FErrorStatus; + + {:Point to error position in reply packet. Not usefull for users. It only + good for debugging!} + property ErrorIndex: Integer read FErrorIndex write FErrorIndex; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property NonRepeaters: Integer read FErrorStatus write FErrorStatus; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property MaxRepetitions: Integer read FErrorIndex write FErrorIndex; + + {:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.} + property MaxSize: Integer read FMaxSize write FMaxSize; + + {:Specify if message is authorised or encrypted. Used only in SNMPv3.} + property Flags: TV3Flags read FFlags write FFlags; + + {:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some + error).} + property FlagReportable: Boolean read FFlagReportable write FFlagReportable; + + {:For SNMPv3. If not specified, is used value from @link(AuthEngineID)} + property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID; + + {:For SNMPv3.} + property ContextName: AnsiString read FContextName write FContextName; + + {:For SNMPv3. Specify Authorization mode. (specify used hash for + authorization)} + property AuthMode: TV3Auth read FAuthMode write FAuthMode; + + {:For SNMPv3. Specify Privacy mode.} + property PrivMode: TV3Priv read FPrivMode write FPrivMode; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp; + + {:SNMPv3 authorization username} + property UserName: AnsiString read FUserName write FUserName; + + {:SNMPv3 authorization password} + property Password: AnsiString read FPassword write FPassword; + + {:For SNMPv3. Computed Athorization key from @link(password).} + property AuthKey: AnsiString read FAuthKey write FAuthKey; + + {:SNMPv3 privacy password} + property PrivPassword: AnsiString read FPrivPassword write FPrivPassword; + + {:For SNMPv3. Computed Privacy key from @link(PrivPassword).} + property PrivKey: AnsiString read FPrivKey write FPrivKey; + + {:MIB value to identify the object that sent the TRAPv1.} + property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise; + + {:Address of TRAPv1 sender (IP address).} + property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost; + + {:Generic TRAPv1 identification.} + property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen; + + {:Specific TRAPv1 identification.} + property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec; + + {:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)} + property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks; + end; + + {:@abstract(Implementation of SNMP protocol.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSNMPSend = class(TSynaClient) + protected + FSock: TUDPBlockSocket; + FBuffer: AnsiString; + FHostIP: AnsiString; + FQuery: TSNMPRec; + FReply: TSNMPRec; + function InternalSendSnmp(const Value: TSNMPRec): Boolean; + function InternalRecvSnmp(const Value: TSNMPRec): Boolean; + function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; + function GetV3EngineID: AnsiString; + function GetV3Sync: TV3Sync; + public + constructor Create; + destructor Destroy; override; + + {:Connects to a Host and send there query. If in timeout SNMP server send + back query, result is @true. If is used SNMPv3, then it synchronize self + with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)} + function SendRequest: Boolean; + + {:Send SNMP packet only, but not waits for reply. Good for sending traps.} + function SendTrap: Boolean; + + {:Receive SNMP packet only. Good for receiving traps.} + function RecvTrap: Boolean; + + {:Mapped to @link(SendRequest) internally. This function is only for + backward compatibility.} + function DoIt: Boolean; + published + {:contains raw binary form of SNMP packet. Good for debugging.} + property Buffer: AnsiString read FBuffer write FBuffer; + + {:After SNMP operation hold IP address of remote side.} + property HostIP: AnsiString read FHostIP; + + {:Data object contains SNMP query.} + property Query: TSNMPRec read FQuery; + + {:Data object contains SNMP reply.} + property Reply: TSNMPRec read FReply; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TUDPBlockSocket read FSock; + end; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GET method of the SNMP protocol. The MIB value is + located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:This is useful function and example of use TSNMPSend object. It implements + the basic SET method of the SNMP protocol. If the SNMP operation is successful, + the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community" + access identifier. You must specify "ValueType" too.} +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GETNEXT method of the SNMP protocol. The MIB value + is located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB tables. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + Table is readed into stringlist, where each string is comma delimited string. + + Warning: this function is not have best performance. For better performance + you must write your own function. best performace you can get by knowledge + of structuture of table and by more then one MIB on one query. } +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB table element. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + As next you must specify identificator of row and column for specify of needed + field of table.} +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements a TRAPv1 to send with all data in the parameters.} +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It receives a TRAPv1 and returns all the data that comes with it.} +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; const MIBName, + MIBValue: TStringList): Integer; + +implementation + +{==============================================================================} + +constructor TSNMPRec.Create; +begin + inherited Create; + FSNMPMibList := TList.Create; + Clear; + FAuthMode := AuthMD5; + FPassword := ''; + FPrivMode := PrivDES; + FPrivPassword := ''; + FID := 1; + FMaxSize := 1472; +end; + +destructor TSNMPRec.Destroy; +var + i: Integer; +begin + for i := 0 to FSNMPMibList.Count - 1 do + TSNMPMib(FSNMPMibList[i]).Free; + FSNMPMibList.Clear; + FSNMPMibList.Free; + inherited Destroy; +end; + +function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString; +var + key: AnsiString; +begin + case FAuthMode of + AuthMD5: + begin + key := MD5LongHash(Value, 1048576); + Result := MD5(key + FAuthEngineID + key); + end; + AuthSHA1: + begin + key := SHA1LongHash(Value, 1048576); + Result := SHA1(key + FAuthEngineID + key); + end; + else + Result := ''; + end; +end; + +function TSNMPRec.DecryptPDU(const value: AnsiString): AnsiString; +var + des: TSynaDes; + des3: TSyna3Des; + aes: TSynaAes; + s: string; +begin + FPrivKey := ''; + if FFlags <> AuthPriv then + Result := value + else + begin + case FPrivMode of + Priv3DES: + begin + FPrivKey := Pass2Key(FPrivPassword); + FPrivKey := FPrivKey + Pass2Key(FPrivKey); + des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); + try + s := PadString(FPrivKey, 32, #0); + delete(s, 1, 24); + des3.SetIV(xorstring(s, FPrivSalt)); + s := des3.DecryptCBC(value); + Result := s; + finally + des3.free; + end; + end; + PrivAES: + begin + FPrivKey := Pass2Key(FPrivPassword); + aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); + try + s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; + aes.SetIV(s); + s := aes.DecryptCFBblock(value); + Result := s; + finally + aes.free; + end; + end; + else //PrivDES as default + begin + FPrivKey := Pass2Key(FPrivPassword); + des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); + try + s := PadString(FPrivKey, 16, #0); + delete(s, 1, 8); + des.SetIV(xorstring(s, FPrivSalt)); + s := des.DecryptCBC(value); + Result := s; + finally + des.free; + end; + end; + end; + end; +end; + +function TSNMPRec.DecodeBuf(Buffer: AnsiString): Boolean; +var + Pos: Integer; + EndPos: Integer; + sm, sv: AnsiString; + Svt: Integer; + s: AnsiString; + Spos: integer; + x: Byte; +begin + Clear; + Result := False; + if Length(Buffer) < 2 then + Exit; + if (Ord(Buffer[1]) and $20) = 0 then + Exit; + Pos := 2; + EndPos := ASNDecLen(Pos, Buffer); + if Length(Buffer) < (EndPos + 2) then + Exit; + Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + + if FVersion = 3 then + begin + ASNItem(Pos, Buffer, Svt); //header data seq + ASNItem(Pos, Buffer, Svt); //ID + FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); + x := 0; + if s <> '' then + x := Ord(s[1]); + FFlagReportable := (x and 4) > 0; + x := x and 3; + case x of + 1: + FFlags := AuthNoPriv; + 3: + FFlags := AuthPriv; + else + FFlags := NoAuthNoPriv; + end; + + x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); //SecurityParameters + //if SecurityModel is USM, then try to decode SecurityParameters + if (x = 3) and (s <> '') then + begin + spos := 1; + ASNItem(SPos, s, Svt); + FAuthEngineID := ASNItem(SPos, s, Svt); + FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTimeStamp := GetTick; + FUserName := ASNItem(SPos, s, Svt); + FAuthKey := ASNItem(SPos, s, Svt); + FPrivSalt := ASNItem(SPos, s, Svt); + end; + //scopedPDU + if FFlags = AuthPriv then + begin + x := Pos; + s := ASNItem(Pos, Buffer, Svt); + if Svt <> ASN1_OCTSTR then + exit; + s := DecryptPDU(s); + //replace encoded content by decoded version and continue + Buffer := copy(Buffer, 1, x - 1); + Buffer := Buffer + s; + Pos := x; + if length(Buffer) < EndPos then + EndPos := length(buffer); + end; + ASNItem(Pos, Buffer, Svt); //skip sequence mark + FContextEngineID := ASNItem(Pos, Buffer, Svt); + FContextName := ASNItem(Pos, Buffer, Svt); + end + else + begin + //old packet + Self.FCommunity := ASNItem(Pos, Buffer, Svt); + end; + + ASNItem(Pos, Buffer, Svt); + Self.FPDUType := Svt; + if Self.FPDUType = PDUTrap then + begin + FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt); + FOldTrapHost := ASNItem(Pos, Buffer, Svt); + FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end + else + begin + Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end; + ASNItem(Pos, Buffer, Svt); + while Pos < EndPos do + begin + ASNItem(Pos, Buffer, Svt); + Sm := ASNItem(Pos, Buffer, Svt); + Sv := ASNItem(Pos, Buffer, Svt); + if sm <> '' then + Self.MIBAdd(sm, sv, Svt); + end; + Result := True; +end; + +function TSNMPRec.EncryptPDU(const value: AnsiString): AnsiString; +var + des: TSynaDes; + des3: TSyna3Des; + aes: TSynaAes; + s: string; + x: integer; +begin + FPrivKey := ''; + if FFlags <> AuthPriv then + Result := Value + else + begin + case FPrivMode of + Priv3DES: + begin + FPrivKey := Pass2Key(FPrivPassword); + FPrivKey := FPrivKey + Pass2Key(FPrivKey); + des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); + try + s := PadString(FPrivKey, 32, #0); + delete(s, 1, 24); + FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := xorstring(s, FPrivSalt); + des3.SetIV(s); + x := length(value) mod 8; + x := 8 - x; + if x = 8 then + x := 0; + s := des3.EncryptCBC(value + Stringofchar(#0, x)); + Result := ASNObject(s, ASN1_OCTSTR); + finally + des3.free; + end; + end; + PrivAES: + begin + FPrivKey := Pass2Key(FPrivPassword); + aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); + try + FPrivSalt := CodeLongInt(0) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; + aes.SetIV(s); + s := aes.EncryptCFBblock(value); + Result := ASNObject(s, ASN1_OCTSTR); + finally + aes.free; + end; + end; + else //PrivDES as default + begin + FPrivKey := Pass2Key(FPrivPassword); + des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); + try + s := PadString(FPrivKey, 16, #0); + delete(s, 1, 8); + FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); + inc(FPrivSaltCounter); + s := xorstring(s, FPrivSalt); + des.SetIV(s); + x := length(value) mod 8; + x := 8 - x; + if x = 8 then + x := 0; + s := des.EncryptCBC(value + Stringofchar(#0, x)); + Result := ASNObject(s, ASN1_OCTSTR); + finally + des.free; + end; + end; + end; + end; +end; + +function TSNMPRec.EncodeBuf: AnsiString; +var + s: AnsiString; + SNMPMib: TSNMPMib; + n: Integer; + pdu, head, auth, authbeg: AnsiString; + x: Byte; +begin + pdu := ''; + for n := 0 to FSNMPMibList.Count - 1 do + begin + SNMPMib := TSNMPMib(FSNMPMibList[n]); + case SNMPMib.ValueType of + ASN1_INT: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); + ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); + ASN1_OBJID: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType); + ASN1_IPADDR: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType); + ASN1_NULL: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject('', ASN1_NULL); + ASN1_COUNTER64: + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(ASNEncInt(StrToInt64Def(SNMPMib.Value, 0)), SNMPMib.ValueType); + else + s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + + ASNObject(SNMPMib.Value, SNMPMib.ValueType); + end; + pdu := pdu + ASNObject(s, ASN1_SEQ); + end; + pdu := ASNObject(pdu, ASN1_SEQ); + + if Self.FPDUType = PDUTrap then + pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) + + ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) + + ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) + + ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) + + ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) + + pdu + else + pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) + + pdu; + pdu := ASNObject(pdu, Self.FPDUType); + + if FVersion = 3 then + begin + if FContextEngineID = '' then + FContextEngineID := FAuthEngineID; + //complete PDUv3... + pdu := ASNObject(FContextEngineID, ASN1_OCTSTR) + + ASNObject(FContextName, ASN1_OCTSTR) + + pdu; + pdu := ASNObject(pdu, ASN1_SEQ); + //encrypt PDU if Priv mode is enabled + pdu := EncryptPDU(pdu); + + //prepare flags + case FFlags of + AuthNoPriv: + x := 1; + AuthPriv: + x := 3; + else + x := 0; + end; + if FFlagReportable then + x := x or 4; + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT); + s := ASNObject(ASNEncInt(FID), ASN1_INT) + + ASNObject(ASNEncInt(FMaxSize), ASN1_INT) + + ASNObject(AnsiChar(x), ASN1_OCTSTR) + //encode security model USM + + ASNObject(ASNEncInt(3), ASN1_INT); + head := head + ASNObject(s, ASN1_SEQ); + + //compute engine time difference + if FAuthEngineTimeStamp = 0 then //out of sync + x := 0 + else + x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000; + + authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR) + + ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT) + + ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT) + + ASNObject(FUserName, ASN1_OCTSTR); + + + case FFlags of + AuthNoPriv, + AuthPriv: + begin + s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR) + + ASNObject(FPrivSalt, ASN1_OCTSTR); + s := ASNObject(s, ASN1_SEQ); + s := head + ASNObject(s, ASN1_OCTSTR); + s := ASNObject(s + pdu, ASN1_SEQ); + //in s is entire packet without auth info... + case FAuthMode of + AuthMD5: + begin + s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48)); + //strip to HMAC-MD5-96 + delete(s, 13, 4); + end; + AuthSHA1: + begin + s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44)); + //strip to HMAC-SHA-96 + delete(s, 13, 8); + end; + else + s := ''; + end; + FAuthKey := s; + end; + end; + + auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR) + + ASNObject(FPrivSalt, ASN1_OCTSTR); + auth := ASNObject(auth, ASN1_SEQ); + + head := head + ASNObject(auth, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); + end + else + begin + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) + + ASNObject(Self.FCommunity, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); + end; + inc(self.FID); +end; + +procedure TSNMPRec.Clear; +var + i: Integer; +begin + FVersion := SNMP_V1; + FCommunity := 'public'; + FUserName := ''; + FPDUType := 0; + FErrorStatus := 0; + FErrorIndex := 0; + for i := 0 to FSNMPMibList.Count - 1 do + TSNMPMib(FSNMPMibList[i]).Free; + FSNMPMibList.Clear; + FOldTrapEnterprise := ''; + FOldTrapHost := ''; + FOldTrapGen := 0; + FOldTrapSpec := 0; + FOldTrapTimeTicks := 0; + FFlags := NoAuthNoPriv; + FFlagReportable := false; + FContextEngineID := ''; + FContextName := ''; + FAuthEngineID := ''; + FAuthEngineBoots := 0; + FAuthEngineTime := 0; + FAuthEngineTimeStamp := 0; + FAuthKey := ''; + FPrivKey := ''; + FPrivSalt := ''; + FPrivSaltCounter := random(maxint); +end; + +procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); +var + SNMPMib: TSNMPMib; +begin + SNMPMib := TSNMPMib.Create; + SNMPMib.OID := MIB; + SNMPMib.Value := Value; + SNMPMib.ValueType := ValueType; + FSNMPMibList.Add(SNMPMib); +end; + +procedure TSNMPRec.MIBDelete(Index: Integer); +begin + if (Index >= 0) and (Index < MIBCount) then + begin + TSNMPMib(FSNMPMibList[Index]).Free; + FSNMPMibList.Delete(Index); + end; +end; + +function TSNMPRec.MIBCount: integer; +begin + Result := FSNMPMibList.Count; +end; + +function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib; +begin + Result := nil; + if (Index >= 0) and (Index < MIBCount) then + Result := TSNMPMib(FSNMPMibList[Index]); +end; + +function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString; +var + i: Integer; +begin + Result := ''; + for i := 0 to MIBCount - 1 do + begin + if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then + begin + Result := (TSNMPMib(FSNMPMibList[i])).Value; + Break; + end; + end; +end; + +{==============================================================================} + +constructor TSNMPSend.Create; +begin + inherited Create; + FQuery := TSNMPRec.Create; + FReply := TSNMPRec.Create; + FQuery.Clear; + FReply.Clear; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 5000; + FTargetPort := cSnmpProtocol; + FHostIP := ''; +end; + +destructor TSNMPSend.Destroy; +begin + FSock.Free; + FReply.Free; + FQuery.Free; + inherited Destroy; +end; + +function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean; +begin + FBuffer := Value.EncodeBuf; + FSock.SendString(FBuffer); + Result := FSock.LastError = 0; +end; + +function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean; +begin + Result := False; + FReply.Clear; + FHostIP := cAnyHost; + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + FHostIP := FSock.GetRemoteSinIP; + Result := Value.DecodeBuf(FBuffer); + end; +end; + +function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; +begin + Result := False; + RValue.AuthMode := QValue.AuthMode; + RValue.Password := QValue.Password; + RValue.PrivMode := QValue.PrivMode; + RValue.PrivPassword := QValue.PrivPassword; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + if InternalSendSnmp(QValue) then + Result := InternalRecvSnmp(RValue); +end; + +function TSNMPSend.SendRequest: Boolean; +var + sync: TV3Sync; +begin + Result := False; + if FQuery.FVersion = 3 then + begin + sync := GetV3Sync; + FQuery.AuthEngineBoots := Sync.EngineBoots; + FQuery.AuthEngineTime := Sync.EngineTime; + FQuery.AuthEngineTimeStamp := Sync.EngineStamp; + FQuery.AuthEngineID := Sync.EngineID; + end; + Result := InternalSendRequest(FQuery, FReply); +end; + +function TSNMPSend.SendTrap: Boolean; +begin + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := InternalSendSnmp(FQuery); +end; + +function TSNMPSend.RecvTrap: Boolean; +begin + FSock.Bind(FIPInterface, FTargetPort); + Result := InternalRecvSnmp(FReply); +end; + +function TSNMPSend.DoIt: Boolean; +begin + Result := SendRequest; +end; + +function TSNMPSend.GetV3EngineID: AnsiString; +var + DisQuery: TSNMPRec; +begin + Result := ''; + DisQuery := TSNMPRec.Create; + try + DisQuery.Version := 3; + DisQuery.UserName := ''; + DisQuery.FlagReportable := True; + DisQuery.PDUType := PDUGetRequest; + if InternalSendRequest(DisQuery, FReply) then + Result := FReply.FAuthEngineID; + finally + DisQuery.Free; + end; +end; + +function TSNMPSend.GetV3Sync: TV3Sync; +var + SyncQuery: TSNMPRec; +begin + Result.EngineID := GetV3EngineID; + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + if Result.EngineTime = 0 then + begin + //still not have sync... + SyncQuery := TSNMPRec.Create; + try + SyncQuery.Version := 3; + SyncQuery.UserName := FQuery.UserName; + SyncQuery.Password := FQuery.Password; + SyncQuery.FlagReportable := True; + SyncQuery.Flags := FQuery.Flags; + SyncQuery.AuthMode := FQuery.AuthMode; + SyncQuery.PrivMode := FQuery.PrivMode; + SyncQuery.PrivPassword := FQuery.PrivPassword; + SyncQuery.PDUType := PDUGetRequest; + SyncQuery.AuthEngineID := FReply.FAuthEngineID; + if InternalSendRequest(SyncQuery, FReply) then + begin + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + end; + finally + SyncQuery.Free; + end; + end; +end; + +{==============================================================================} + +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + SNMPSend.TargetHost := SNMPHost; + Result := SNMPSend.SendRequest; + Value := ''; + if Result then + Value := SNMPSend.Reply.MIBGet(OID); + finally + SNMPSend.Free; + end; +end; + +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.Query.Clear; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUSetRequest; + SNMPSend.Query.MIBAdd(OID, Value, ValueType); + SNMPSend.TargetHost := SNMPHost; + Result := SNMPSend.Sendrequest = True; + finally + SNMPSend.Free; + end; +end; + +function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString; + const Community: AnsiString; var Value: AnsiString): Boolean; +begin + SNMPSend.Query.Clear; + SNMPSend.Query.ID := SNMPSend.Query.ID + 1; + SNMPSend.Query.Community := Community; + SNMPSend.Query.PDUType := PDUGetNextRequest; + SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); + Result := SNMPSend.Sendrequest; + Value := ''; + if Result then + if SNMPSend.Reply.SNMPMibList.Count > 0 then + begin + OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID; + Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value; + end; +end; + +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.TargetHost := SNMPHost; + Result := InternalGetNext(SNMPSend, OID, Community, Value); + finally + SNMPSend.Free; + end; +end; + +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; +var + OID: AnsiString; + s: AnsiString; + col,row: String; + x: integer; + SNMPSend: TSNMPSend; + RowList: TStringList; +begin + Value.Clear; + SNMPSend := TSNMPSend.Create; + RowList := TStringList.Create; + try + SNMPSend.TargetHost := SNMPHost; + OID := BaseOID; + repeat + Result := InternalGetNext(SNMPSend, OID, Community, s); + if Pos(BaseOID, OID) <> 1 then + break; + row := separateright(oid, baseoid + '.'); + col := fetch(row, '.'); + + if IsBinaryString(s) then + s := StrToHex(s); + x := RowList.indexOf(Row); + if x < 0 then + begin + x := RowList.add(Row); + Value.Add(''); + end; + if (Value[x] <> '') then + Value[x] := Value[x] + ','; + Value[x] := Value[x] + AnsiQuotedStr(s, '"'); + until not result; + finally + SNMPSend.Free; + RowList.Free; + end; +end; + +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; +var + s: AnsiString; +begin + s := BaseOID + '.' + ColID + '.' + RowID; + Result := SnmpGet(s, Community, SNMPHost, Value); +end; + +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.TargetHost := Dest; + SNMPSend.TargetPort := cSnmpTrapProtocol; + SNMPSend.Query.Community := Community; + SNMPSend.Query.Version := SNMP_V1; + SNMPSend.Query.PDUType := PDUTrap; + SNMPSend.Query.OldTrapHost := Source; + SNMPSend.Query.OldTrapEnterprise := Enterprise; + SNMPSend.Query.OldTrapGen := Generic; + SNMPSend.Query.OldTrapSpec := Specific; + SNMPSend.Query.OldTrapTimeTicks := Seconds; + SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType); + Result := Ord(SNMPSend.SendTrap); + finally + SNMPSend.Free; + end; +end; + +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; + const MIBName, MIBValue: TStringList): Integer; +var + SNMPSend: TSNMPSend; + i: Integer; +begin + SNMPSend := TSNMPSend.Create; + try + Result := 0; + SNMPSend.TargetPort := cSnmpTrapProtocol; + if SNMPSend.RecvTrap then + begin + Result := 1; + Dest := SNMPSend.HostIP; + Community := SNMPSend.Reply.Community; + Source := SNMPSend.Reply.OldTrapHost; + Enterprise := SNMPSend.Reply.OldTrapEnterprise; + Generic := SNMPSend.Reply.OldTrapGen; + Specific := SNMPSend.Reply.OldTrapSpec; + Seconds := SNMPSend.Reply.OldTrapTimeTicks; + MIBName.Clear; + MIBValue.Clear; + for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do + begin + MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID); + MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value); + end; + end; + finally + SNMPSend.Free; + end; +end; + + +end. + + diff --git a/sntpsend.pas b/sntpsend.pas new file mode 100644 index 0000000..c4d76a8 --- /dev/null +++ b/sntpsend.pas @@ -0,0 +1,382 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.000.003 | +|==============================================================================| +| Content: SNTP client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Patrick Chevalley | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract( NTP and SNTP client) + +Used RFC: RFC-1305, RFC-2030 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit sntpsend; + +interface + +uses + SysUtils, synabyte, + synsock, blcksock, synautil; + +const + cNtpProtocol = '123'; + +type + + {:@abstract(Record containing the NTP packet.)} + TNtp = packed record + mode: Byte; + stratum: Byte; + poll: Byte; + Precision: Byte; + RootDelay: Longint; + RootDisperson: Longint; + RefID: Longint; + Ref1: Longint; + Ref2: Longint; + Org1: Longint; + Org2: Longint; + Rcv1: Longint; + Rcv2: Longint; + Xmit1: Longint; + Xmit2: Longint; + end; + + {:@abstract(Implementation of NTP and SNTP client protocol), + include time synchronisation. It can send NTP or SNTP time queries, or it + can receive NTP broadcasts too. + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TSNTPSend = class(TSynaClient) + private + FNTPReply: TNtp; + FNTPTime: TDateTime; + FNTPOffset: double; + FNTPDelay: double; + FMaxSyncDiff: double; + FSyncTime: Boolean; + FSock: TUDPBlockSocket; + FBuffer: TSynaBytes; + FLi, FVn, Fmode : byte; + function StrToNTP(const Value: TSynaBytes): TNtp; + function NTPtoStr(const Value: Tntp): TSynaBytes; + procedure ClearNTP(var Value: Tntp); + public + constructor Create; + destructor Destroy; override; + + {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} + function DecodeTs(Nsec, Nfrac: Longint): TDateTime; + + {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} + procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid.} + function GetSNTP: Boolean; + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid. Result time is after all needed corrections.} + function GetNTP: Boolean; + + {:Wait for broadcast NTP packet. If all OK, result is @true and + @link(NTPReply) and @link(NTPTime) are valid.} + function GetBroadcastNTP: Boolean; + + {:Holds last received NTP packet.} + property NTPReply: TNtp read FNTPReply; + published + {:Date and time of remote NTP or SNTP server. (UTC time!!!)} + property NTPTime: TDateTime read FNTPTime; + + {:Offset between your computer and remote NTP or SNTP server.} + property NTPOffset: Double read FNTPOffset; + + {:Delay between your computer and remote NTP or SNTP server.} + property NTPDelay: Double read FNTPDelay; + + {:Define allowed maximum difference between your time and remote time for + synchronising time. If difference is bigger, your system time is not + changed!} + property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; + + {:If @true, after successfull getting time is local computer clock + synchronised to given time. + For synchronising time you must have proper rights! (Usually Administrator)} + property SyncTime: Boolean read FSyncTime write FSyncTime; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TUDPBlockSocket read FSock; + end; + +implementation + +constructor TSNTPSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSock.Owner := self; + FTimeout := 5000; + FTargetPort := cNtpProtocol; + FMaxSyncDiff := 3600; + FSyncTime := False; +end; + +destructor TSNTPSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TSNTPSend.StrToNTP(const Value: TSynaBytes): TNtp; +begin + if length(FBuffer) >= SizeOf(Result) then + begin + Result.mode := ord(Value[1]); + Result.stratum := ord(Value[2]); + Result.poll := ord(Value[3]); + Result.Precision := ord(Value[4]); + Result.RootDelay := DecodeLongInt(value, 5); + Result.RootDisperson := DecodeLongInt(value, 9); + Result.RefID := DecodeLongInt(value, 13); + Result.Ref1 := DecodeLongInt(value, 17); + Result.Ref2 := DecodeLongInt(value, 21); + Result.Org1 := DecodeLongInt(value, 25); + Result.Org2 := DecodeLongInt(value, 29); + Result.Rcv1 := DecodeLongInt(value, 33); + Result.Rcv2 := DecodeLongInt(value, 37); + Result.Xmit1 := DecodeLongInt(value, 41); + Result.Xmit2 := DecodeLongInt(value, 45); + end; + +end; + +function TSNTPSend.NTPtoStr(const Value: Tntp): TSynaBytes; +begin +{$IFDEF UNICODE} + Result.Length := 4; + Result.Bytes[0] := TSynaByte(Value.mode); + Result.Bytes[1] := TSynaByte(Value.stratum); + Result.Bytes[2] := TSynaByte(Value.poll); + Result.Bytes[3] := TSynaByte(Value.precision); +{$ELSE} + SetLength(Result, 4); + Result[1] := TSynaByte(Value.mode); + Result[2] := TSynaByte(Value.stratum); + Result[3] := TSynaByte(Value.poll); + Result[4] := TSynaByte(Value.precision); +{$ENDIF} + Result := Result + CodeLongInt(Value.RootDelay); + Result := Result + CodeLongInt(Value.RootDisperson); + Result := Result + CodeLongInt(Value.RefID); + Result := Result + CodeLongInt(Value.Ref1); + Result := Result + CodeLongInt(Value.Ref2); + Result := Result + CodeLongInt(Value.Org1); + Result := Result + CodeLongInt(Value.Org2); + Result := Result + CodeLongInt(Value.Rcv1); + Result := Result + CodeLongInt(Value.Rcv2); + Result := Result + CodeLongInt(Value.Xmit1); + Result := Result + CodeLongInt(Value.Xmit2); +end; + +procedure TSNTPSend.ClearNTP(var Value: Tntp); +begin + Value.mode := 0; + Value.stratum := 0; + Value.poll := 0; + Value.Precision := 0; + Value.RootDelay := 0; + Value.RootDisperson := 0; + Value.RefID := 0; + Value.Ref1 := 0; + Value.Ref2 := 0; + Value.Org1 := 0; + Value.Org2 := 0; + Value.Rcv1 := 0; + Value.Rcv2 := 0; + Value.Xmit1 := 0; + Value.Xmit2 := 0; +end; + +function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; +const + maxi = 4294967295.0; +var + d, d1: Double; +begin + d := Nsec; + if d < 0 then + d := maxi + d + 1; + d1 := Nfrac; + if d1 < 0 then + d1 := maxi + d1 + 1; + d1 := d1 / maxi; + d1 := Trunc(d1 * 10000) / 10000; + Result := (d + d1) / 86400; + Result := Result + 2; +end; + +procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); +const + maxi = 4294967295.0; + maxilongint = 2147483647; +var + d, d1: Double; +begin + d := (dt - 2) * 86400; + d1 := frac(d); + if d > maxilongint then + d := d - maxi - 1; + d := trunc(d); + d1 := Trunc(d1 * 10000) / 10000; + d1 := d1 * maxi; + if d1 > maxilongint then + d1 := d1 - maxi - 1; + Nsec:=trunc(d); + Nfrac:=trunc(d1); +end; + +function TSNTPSend.GetBroadcastNTP: Boolean; +var + x: Integer; +begin + Result := False; + FSock.Bind(FIPInterface, FTargetPort); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end; + end; +end; + +function TSNTPSend.GetSNTP: Boolean; +var + q: TNtp; + x: Integer; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + ClearNtp(q); + q.mode := $1B; + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end; + end; +end; + +function TSNTPSend.GetNTP: Boolean; +var + q: TNtp; + x: Integer; + t1, t2, t3, t4 : TDateTime; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + ClearNtp(q); + q.mode := $1B; + t1 := GetUTTime; + EncodeTs(t1, q.org1, q.org2); + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); + FBuffer := FSock.RecvPacket(FTimeout); + if FSock.LastError = 0 then + begin + x := Length(FBuffer); + t4 := GetUTTime; + if x >= SizeOf(NTPReply) then + begin + FNTPReply := StrToNTP(FBuffer); + FLi := (NTPReply.mode and $C0) shr 6; + FVn := (NTPReply.mode and $38) shr 3; + Fmode := NTPReply.mode and $07; + if (Fli < 3) and (Fmode = 4) and + (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and + (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) + then begin + t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); + t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); + FNTPDelay := (T4 - T1) - (T2 - T3); + FNTPTime := t3 + FNTPDelay / 2; + FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; + FNTPDelay := FNTPDelay * 86400; + if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then + SetUTTime(FNTPTime); + Result := True; + end + else result:=false; + end; + end; +end; + +end. diff --git a/ssdotnet.inc b/ssdotnet.inc new file mode 100644 index 0000000..1537491 --- /dev/null +++ b/ssdotnet.inc @@ -0,0 +1,1099 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.002 | +|==============================================================================| +| Content: Socket Independent Platform Layer - .NET definition include | +|==============================================================================| +| Copyright (c)2004, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2004. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF CIL} + +interface + +uses + SyncObjs, SysUtils, Classes, + System.Net, + System.Net.Sockets; + +const + DLLStackName = ''; + WinsockLevel = $0202; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + PSockAddr = IPEndPoint; + DWORD = integer; + ULong = cardinal; + TMemory = Array of byte; + TLinger = LingerOption; + TSocket = socket; + TAddrFamily = AddressFamily; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; +// lpVendorInfo: PChar; + end; + +const + MSG_NOSIGNAL = 0; + INVALID_SOCKET = nil; + AF_UNSPEC = AddressFamily.Unspecified; + AF_INET = AddressFamily.InterNetwork; + AF_INET6 = AddressFamily.InterNetworkV6; + SOCKET_ERROR = integer(-1); + + FIONREAD = integer($4004667f); + FIONBIO = integer($8004667e); + FIOASYNC = integer($8004667d); + + SOMAXCONN = integer($7fffffff); + + IPPROTO_IP = ProtocolType.IP; + IPPROTO_ICMP = ProtocolType.Icmp; + IPPROTO_IGMP = ProtocolType.Igmp; + IPPROTO_TCP = ProtocolType.Tcp; + IPPROTO_UDP = ProtocolType.Udp; + IPPROTO_RAW = ProtocolType.Raw; + IPPROTO_IPV6 = ProtocolType.IPV6; +// + IPPROTO_ICMPV6 = ProtocolType.Icmp; //?? + + SOCK_STREAM = SocketType.Stream; + SOCK_DGRAM = SocketType.Dgram; + SOCK_RAW = SocketType.Raw; + SOCK_RDM = SocketType.Rdm; + SOCK_SEQPACKET = SocketType.Seqpacket; + + SOL_SOCKET = SocketOptionLevel.Socket; + SOL_IP = SocketOptionLevel.Ip; + + + IP_OPTIONS = SocketOptionName.IPOptions; + IP_HDRINCL = SocketOptionName.HeaderIncluded; + IP_TOS = SocketOptionName.TypeOfService; { set/get IP Type Of Service } + IP_TTL = SocketOptionName.IpTimeToLive; { set/get IP Time To Live } + IP_MULTICAST_IF = SocketOptionName.MulticastInterface; { set/get IP multicast interface } + IP_MULTICAST_TTL = SocketOptionName.MulticastTimeToLive; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = SocketOptionName.MulticastLoopback; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = SocketOptionName.AddMembership; { add an IP group membership } + IP_DROP_MEMBERSHIP = SocketOptionName.DropMembership; { drop an IP group membership } + IP_DONTFRAGMENT = SocketOptionName.DontFragment; { set/get IP Don't Fragment flag } + + IPV6_UNICAST_HOPS = 8; // TTL + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + SO_DEBUG = SocketOptionName.Debug; { turn on debugging info recording } + SO_ACCEPTCONN = SocketOptionName.AcceptConnection; { socket has had listen() } + SO_REUSEADDR = SocketOptionName.ReuseAddress; { allow local address reuse } + SO_KEEPALIVE = SocketOptionName.KeepAlive; { keep connections alive } + SO_DONTROUTE = SocketOptionName.DontRoute; { just use interface addresses } + SO_BROADCAST = SocketOptionName.Broadcast; { permit sending of broadcast msgs } + SO_USELOOPBACK = SocketOptionName.UseLoopback; { bypass hardware when possible } + SO_LINGER = SocketOptionName.Linger; { linger on close if data present } + SO_OOBINLINE = SocketOptionName.OutOfBandInline; { leave received OOB data in line } + SO_DONTLINGER = SocketOptionName.DontLinger; +{ Additional options. } + SO_SNDBUF = SocketOptionName.SendBuffer; { send buffer size } + SO_RCVBUF = SocketOptionName.ReceiveBuffer; { receive buffer size } + SO_SNDLOWAT = SocketOptionName.SendLowWater; { send low-water mark } + SO_RCVLOWAT = SocketOptionName.ReceiveLowWater; { receive low-water mark } + SO_SNDTIMEO = SocketOptionName.SendTimeout; { send timeout } + SO_RCVTIMEO = SocketOptionName.ReceiveTimeout; { receive timeout } + SO_ERROR = SocketOptionName.Error; { get error status and clear } + SO_TYPE = SocketOptionName.Type; { get socket type } + +{ WinSock 2 extension -- new options } +// SO_GROUP_ID = $2001; { ID of a socket group} +// SO_GROUP_PRIORITY = $2002; { the relative priority within a group} +// SO_MAX_MSG_SIZE = $2003; { maximum message size } +// SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } +// SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } +// SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; +// PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } +// SO_OPENTYPE = $7008; +// SO_SYNCHRONOUS_ALERT = $10; +// SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } +// SO_MAXDG = $7009; +// SO_MAXPATHDG = $700A; +// SO_UPDATE_ACCEPT_CONTEXT = $700B; +// SO_CONNECT_TIME = $700C; + + + { All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + +type + TVarSin = IPEndpoint; + +{ function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; +} + +{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); +} +{=============================================================================} + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function WSAGetLastErrorDesc: String; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; +// function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar; +// optlen: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; +// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; +// tolen: Integer): Integer; +/// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +/// function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +/// function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +/// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: u_short): u_short; + function ntohl(netlong: u_long): u_long; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; + function htons(hostshort: u_short): u_short; + function htonl(hostlong: u_long): u_long; +// function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetSockName(s: TSocket; var name: TVarSin): Integer; +// function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; +// function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; +// function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; +// function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; +// Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; +// timeout: PTimeVal): Longint; +// {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF}; + +// TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; +// cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; +// lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; +// lpCompletionRoutine: pointer): u_int; +// stdcall; + + function GetPortService(value: string): integer; + +function IsNewApi(Family: TAddrFamily): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +{==============================================================================} +implementation + +threadvar + WSALastError: integer; + WSALastErrorDesc: string; + +var + services: Array [0..139, 0..1] of string = + ( + ('echo', '7'), + ('discard', '9'), + ('sink', '9'), + ('null', '9'), + ('systat', '11'), + ('users', '11'), + ('daytime', '13'), + ('qotd', '17'), + ('quote', '17'), + ('chargen', '19'), + ('ttytst', '19'), + ('source', '19'), + ('ftp-data', '20'), + ('ftp', '21'), + ('telnet', '23'), + ('smtp', '25'), + ('mail', '25'), + ('time', '37'), + ('timeserver', '37'), + ('rlp', '39'), + ('nameserver', '42'), + ('name', '42'), + ('nickname', '43'), + ('whois', '43'), + ('domain', '53'), + ('bootps', '67'), + ('dhcps', '67'), + ('bootpc', '68'), + ('dhcpc', '68'), + ('tftp', '69'), + ('gopher', '70'), + ('finger', '79'), + ('http', '80'), + ('www', '80'), + ('www-http', '80'), + ('kerberos', '88'), + ('hostname', '101'), + ('hostnames', '101'), + ('iso-tsap', '102'), + ('rtelnet', '107'), + ('pop2', '109'), + ('postoffice', '109'), + ('pop3', '110'), + ('sunrpc', '111'), + ('rpcbind', '111'), + ('portmap', '111'), + ('auth', '113'), + ('ident', '113'), + ('tap', '113'), + ('uucp-path', '117'), + ('nntp', '119'), + ('usenet', '119'), + ('ntp', '123'), + ('epmap', '135'), + ('loc-srv', '135'), + ('netbios-ns', '137'), + ('nbname', '137'), + ('netbios-dgm', '138'), + ('nbdatagram', '138'), + ('netbios-ssn', '139'), + ('nbsession', '139'), + ('imap', '143'), + ('imap4', '143'), + ('pcmail-srv', '158'), + ('snmp', '161'), + ('snmptrap', '162'), + ('snmp-trap', '162'), + ('print-srv', '170'), + ('bgp', '179'), + ('irc', '194'), + ('ipx', '213'), + ('ldap', '389'), + ('https', '443'), + ('mcom', '443'), + ('microsoft-ds', '445'), + ('kpasswd', '464'), + ('isakmp', '500'), + ('ike', '500'), + ('exec', '512'), + ('biff', '512'), + ('comsat', '512'), + ('login', '513'), + ('who', '513'), + ('whod', '513'), + ('cmd', '514'), + ('shell', '514'), + ('syslog', '514'), + ('printer', '515'), + ('spooler', '515'), + ('talk', '517'), + ('ntalk', '517'), + ('efs', '520'), + ('router', '520'), + ('route', '520'), + ('routed', '520'), + ('timed', '525'), + ('timeserver', '525'), + ('tempo', '526'), + ('newdate', '526'), + ('courier', '530'), + ('rpc', '530'), + ('conference', '531'), + ('chat', '531'), + ('netnews', '532'), + ('readnews', '532'), + ('netwall', '533'), + ('uucp', '540'), + ('uucpd', '540'), + ('klogin', '543'), + ('kshell', '544'), + ('krcmd', '544'), + ('new-rwho', '550'), + ('new-who', '550'), + ('remotefs', '556'), + ('rfs', '556'), + ('rfs_server', '556'), + ('rmonitor', '560'), + ('rmonitord', '560'), + ('monitor', '561'), + ('ldaps', '636'), + ('sldap', '636'), + ('doom', '666'), + ('kerberos-adm', '749'), + ('kerberos-iv', '750'), + ('kpop', '1109'), + ('phone', '1167'), + ('ms-sql-s', '1433'), + ('ms-sql-m', '1434'), + ('wins', '1512'), + ('ingreslock', '1524'), + ('ingres', '1524'), + ('l2tp', '1701'), + ('pptp', '1723'), + ('radius', '1812'), + ('radacct', '1813'), + ('nfsd', '2049'), + ('nfs', '2049'), + ('knetd', '2053'), + ('gds_db', '3050'), + ('man', '9535') + ); + +{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and + (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and + (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.s_un_b.s_b1 = char($FF)); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s_un_b.s_b16 := char(1); +end; +} + +{=============================================================================} + +procedure NullErr; +begin + WSALastError := 0; + WSALastErrorDesc := ''; +end; + +procedure GetErrCode(E: System.Exception); +var + SE: System.Net.Sockets.SocketException; +begin + if E is System.Net.Sockets.SocketException then + begin + SE := E as System.Net.Sockets.SocketException; + WSALastError := SE.ErrorCode; + WSALastErrorDesc := SE.Message; + end +end; + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + NullErr; + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on .NET'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + NullErr; + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := WSALastError; +end; + +function WSAGetLastErrorDesc: String; +begin + Result := WSALastErrorDesc; +end; + +function GetHostName: string; +begin + Result := System.Net.DNS.GetHostName; +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.ShutDown(SocketShutdown(how)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +begin + NullErr; + try + result := s.SendTo(Buf, len, SocketFlags(flags), addrto); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Send(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Receive(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +var + EP: EndPoint; +begin + NullErr; + try + EP := from; + result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP)); + from := EP as IPEndPoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function ntohs(netshort: u_short): u_short; +begin + Result := IPAddress.NetworkToHostOrder(NetShort); +end; + +function ntohl(netlong: u_long): u_long; +begin + Result := IPAddress.NetworkToHostOrder(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.Listen(backlog); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +var + inv, outv: TMemory; +begin + Result := 0; + NullErr; + try + if cmd = DWORD(FIONBIO) then + s.Blocking := arg = 0 + else + begin + inv := BitConverter.GetBytes(arg); + outv := BitConverter.GetBytes(integer(0)); + s.IOControl(cmd, inv, outv); + arg := BitConverter.ToInt32(outv, 0); + end; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function htons(hostshort: u_short): u_short; +begin + Result := IPAddress.HostToNetworkOrder(Hostshort); +end; + +function htonl(hostlong: u_long): u_long; +begin + Result := IPAddress.HostToNetworkOrder(HostLong); +end; + +//function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.localEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.RemoteEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Connect(name); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := 0; + NullErr; + try + s.Close; + except + on e: System.Net.Sockets.SocketException do + begin + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Bind(addr); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; +function Accept(s: TSocket; var addr: TVarSin): TSocket; +begin + NullErr; + try + result := s.Accept(); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + NullErr; + try + result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +{=============================================================================} +function GetPortService(value: string): integer; +var + n: integer; +begin + Result := 0; + value := Lowercase(value); + for n := 0 to High(Services) do + if services[n, 0] = value then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + if Result = 0 then + Result := StrToIntDef(value, 0); +end; + +{=============================================================================} +function IsNewApi(Family: TAddrFamily): Boolean; +begin + Result := true; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + IPs: array of IPAddress; + n: integer; + ip4, ip6: string; + sip: string; +begin + sip := ''; + ip4 := ''; + ip6 := ''; + IPs := Dns.Resolve(IP).AddressList; + for n :=low(IPs) to high(IPs) do begin + if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then + ip4 := IPs[n].toString; + if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then + ip6 := IPs[n].toString; + if (ip4 <> '') and (ip6 <> '') then + break; + end; + case Family of + AF_UNSPEC: + begin + if (ip4 <> '') and (ip6 <> '') then + begin + if PreferIP4 then + sip := ip4 + else + Sip := ip6; + end + else + begin + sip := ip4; + if (ip6 <> '') then + sip := ip6; + end; + end; + AF_INET: + sip := ip4; + AF_INET6: + sip := ip6; + end; + sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := Sin.Address.ToString; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + Result := Sin.Port; +end; + +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +var + IPs :array of IPAddress; + n: integer; +begin + IPList.Clear; + IPs := Dns.Resolve(Name).AddressList; + for n := low(IPs) to high(IPs) do + begin + if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET)) + or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then + begin + IPList.Add(IPs[n].toString); + end; + end; +end; + +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; +var + n: integer; +begin + Result := StrToIntDef(port, 0); + if Result = 0 then + begin + port := Lowercase(port); + for n := 0 to High(Services) do + if services[n, 0] = port then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + end; +end; + +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +begin + Result := Dns.GetHostByAddress(IP).HostName; +end; + + +{=============================================================================} +function InitSocketInterface(stack: string): Boolean; +begin + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + NullErr; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; +// SET_IN6_IF_ADDR_ANY (@in6addr_any); +// SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + NullErr; + SynSockCS.Free; +end; + +{$ENDIF} diff --git a/ssfpc.inc b/ssfpc.inc new file mode 100644 index 0000000..e8f14fb --- /dev/null +++ b/ssfpc.inc @@ -0,0 +1,926 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.005 | +|==============================================================================| +| Content: Socket Independent Platform Layer - FreePascal definition include | +|==============================================================================| +| Copyright (c)2006-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2006-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF FPC} +{For FreePascal 2.x.x} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$ifdef FreeBSD} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} +{$ifdef darwin} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} + +interface + +uses + SyncObjs, SysUtils, Classes, + synafpc, BaseUnix, Unix, termio, sockets, netdb; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; + +type + TSocket = longint; + TAddrFamily = integer; + + TMemory = pointer; + + +type + TFDSet = Baseunix.TFDSet; + PFDSet = ^TFDSet; + Ptimeval = Baseunix.ptimeval; + Ttimeval = Baseunix.ttimeval; + +const + FIONREAD = termio.FIONREAD; + FIONBIO = termio.FIONBIO; + FIOASYNC = termio.FIOASYNC; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + PInAddr = ^TInAddr; + TInAddr = sockets.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = sockets.TInetSockAddr; + + + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + + PInAddr6 = ^TInAddr6; + TInAddr6 = sockets.Tin6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = sockets.TInetSockAddr6; + + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = sockets.IP_TTL; { int; IP time to live. } + IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } +// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } + IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } + IP_RETOPTS = sockets.IP_RETOPTS; { bool } +// IP_PKTINFO = sockets.IP_PKTINFO; { bool } +// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; +// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } +// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } +// IP_RECVERR = sockets.IP_RECVERR; { bool } +// IP_RECVTTL = sockets.IP_RECVTTL; { bool } +// IP_RECVTOS = sockets.IP_RECVTOS; { bool } + IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = sockets.SOL_SOCKET; + + SO_DEBUG = sockets.SO_DEBUG; + SO_REUSEADDR = sockets.SO_REUSEADDR; + SO_TYPE = sockets.SO_TYPE; + SO_ERROR = sockets.SO_ERROR; + SO_DONTROUTE = sockets.SO_DONTROUTE; + SO_BROADCAST = sockets.SO_BROADCAST; + SO_SNDBUF = sockets.SO_SNDBUF; + SO_RCVBUF = sockets.SO_RCVBUF; + SO_KEEPALIVE = sockets.SO_KEEPALIVE; + SO_OOBINLINE = sockets.SO_OOBINLINE; +// SO_NO_CHECK = sockets.SO_NO_CHECK; +// SO_PRIORITY = sockets.SO_PRIORITY; + SO_LINGER = sockets.SO_LINGER; +// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; +// SO_REUSEPORT = sockets.SO_REUSEPORT; +// SO_PASSCRED = sockets.SO_PASSCRED; +// SO_PEERCRED = sockets.SO_PEERCRED; + SO_RCVLOWAT = sockets.SO_RCVLOWAT; + SO_SNDLOWAT = sockets.SO_SNDLOWAT; + SO_RCVTIMEO = sockets.SO_RCVTIMEO; + SO_SNDTIMEO = sockets.SO_SNDTIMEO; +{ Security levels - as per NRL IPv6 - don't actually do anything } +// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; +// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; +// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; +// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; +{ Socket filtering } +// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; +// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; + +{$IFDEF DARWIN} + SO_NOSIGPIPE = $1022; +{$ENDIF} + + SOMAXCONN = 1024; + + IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 10; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + + MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. + MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. + {$ifdef DARWIN} + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + // Works under MAC OS X, but is undocumented, + // So FPC doesn't include it + {$else} + MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. + {$endif} + +const + WSAEINTR = ESysEINTR; + WSAEBADF = ESysEBADF; + WSAEACCES = ESysEACCES; + WSAEFAULT = ESysEFAULT; + WSAEINVAL = ESysEINVAL; + WSAEMFILE = ESysEMFILE; + WSAEWOULDBLOCK = ESysEWOULDBLOCK; + WSAEINPROGRESS = ESysEINPROGRESS; + WSAEALREADY = ESysEALREADY; + WSAENOTSOCK = ESysENOTSOCK; + WSAEDESTADDRREQ = ESysEDESTADDRREQ; + WSAEMSGSIZE = ESysEMSGSIZE; + WSAEPROTOTYPE = ESysEPROTOTYPE; + WSAENOPROTOOPT = ESysENOPROTOOPT; + WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; + WSAEOPNOTSUPP = ESysEOPNOTSUPP; + WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; + WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; + WSAEADDRINUSE = ESysEADDRINUSE; + WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; + WSAENETDOWN = ESysENETDOWN; + WSAENETUNREACH = ESysENETUNREACH; + WSAENETRESET = ESysENETRESET; + WSAECONNABORTED = ESysECONNABORTED; + WSAECONNRESET = ESysECONNRESET; + WSAENOBUFS = ESysENOBUFS; + WSAEISCONN = ESysEISCONN; + WSAENOTCONN = ESysENOTCONN; + WSAESHUTDOWN = ESysESHUTDOWN; + WSAETOOMANYREFS = ESysETOOMANYREFS; + WSAETIMEDOUT = ESysETIMEDOUT; + WSAECONNREFUSED = ESysECONNREFUSED; + WSAELOOP = ESysELOOP; + WSAENAMETOOLONG = ESysENAMETOOLONG; + WSAEHOSTDOWN = ESysEHOSTDOWN; + WSAEHOSTUNREACH = ESysEHOSTUNREACH; + WSAENOTEMPTY = ESysENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = ESysEUSERS; + WSAEDQUOT = ESysEDQUOT; + WSAESTALE = ESysESTALE; + WSAEREMOTE = ESysEREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = 1; + WSATRY_AGAIN = 2; + WSANO_RECOVERY = 3; + WSANO_DATA = -6; + WSABASEERR = 10000; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); + +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + {$ifdef SOCK_HAS_SINLEN} + sin_len : cuchar; + {$endif} + case integer of + 0: (AddressFamily: sa_family_t); + 1: ( + case sin_family: sa_family_t of + AF_INET: (sin_port: word; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: word; + sin6_flowinfo: longword; + sin6_addr: TInAddr6; + sin6_scope_id: longword); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; + function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; + function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: word): word; + function ntohl(netlong: longword): longword; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; + function htons(hostshort: word): word; + function htonl(hostlong: longword): longword; + function GetSockName(s: TSocket; var name: TVarSin): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; + function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + + +{==============================================================================} +implementation + + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Unix/Linux by FreePascal'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := fpGetErrno; +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := fpFD_ISSET(socket, fdset) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_SET(Socket, fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_CLR(Socket, fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + fpFD_ZERO(fdset); +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := fpGetSockName(s, @name, @Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := fpGetPeerName(s, @name, @Len); +end; + +function GetHostName: string; +begin + Result := unix.GetHostName; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := fpSend(s, pointer(Buf), len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := fpRecv(s, pointer(Buf), len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := fpAccept(s, @addr, @x); +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := fpShutdown(s, how); +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := fpsetsockopt(s, level, optname, pointer(optval), optlen); +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen); +end; + +function ntohs(netshort: word): word; +begin + Result := sockets.ntohs(NetShort); +end; + +function ntohl(netlong: longword): longword; +begin + Result := sockets.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if fpListen(s, backlog) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +begin + Result := fpIoctl(s, cmd, @arg); +end; + +function htons(hostshort: word): word; +begin + Result := sockets.htons(Hostshort); +end; + +function htonl(hostlong: longword): longword; +begin + Result := sockets.htonl(HostLong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := sockets.CloseSocket(s); +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +{$IFDEF DARWIN} +var + on_off: integer; +{$ENDIF} +begin + Result := fpSocket(af, struc, protocol); +// ##### Patch for Mac OS to avoid "Project XXX raised exception class 'External: SIGPIPE'" error. +{$IFDEF DARWIN} + if Result <> INVALID_SOCKET then + begin + on_off := 1; + synsock.SetSockOpt(Result, integer(SOL_SOCKET), integer(SO_NOSIGPIPE), @on_off, SizeOf(integer)); + end; +{$ENDIF} +end; + +function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + TwoPass: boolean; + f1, f2: integer; + + function GetAddr(f:integer): integer; + var + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + he: THostEntry; + begin + Result := WSAEPROTONOSUPPORT; + case f of + AF_INET: + begin + if IP = cAnyHost then + begin + Sin.sin_family := AF_INET; + Result := 0; + end + else + begin + if lowercase(IP) = cLocalHostStr then + a4[1].s_addr := htonl(INADDR_LOOPBACK) + else + begin + a4[1].s_addr := 0; + Result := WSAHOST_NOT_FOUND; + a4[1] := StrTonetAddr(IP); + if a4[1].s_addr = INADDR_ANY then + if GetHostByName(ip, he) then + a4[1]:=HostToNet(he.Addr) + else + Resolvename(ip, a4); + end; + if a4[1].s_addr <> INADDR_ANY then + begin + Sin.sin_family := AF_INET; + sin.sin_addr := a4[1]; + Result := 0; + end; + end; + end; + AF_INET6: + begin + if IP = c6AnyHost then + begin + Sin.sin_family := AF_INET6; + Result := 0; + end + else + begin + if lowercase(IP) = cLocalHostStr then + SET_LOOPBACK_ADDR6(@a6[1]) + else + begin + Result := WSAHOST_NOT_FOUND; + SET_IN6_IF_ADDR_ANY(@a6[1]); + a6[1] := StrTonetAddr6(IP); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + Resolvename6(ip, a6); + end; + if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + begin + Sin.sin_family := AF_INET6; + sin.sin6_addr := a6[1]; + Result := 0; + end; + end; + end; + end; + end; +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + f1 := AF_INET; + f2 := AF_INET6; + TwoPass := True; + end + else + begin + f2 := AF_INET; + f1 := AF_INET6; + TwoPass := True; + end; + end + else + f1 := Family; + Result := GetAddr(f1); + if Result <> 0 then + if TwoPass then + Result := GetAddr(f2); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := ''; + case sin.AddressFamily of + AF_INET: + begin + result := NetAddrToStr(sin.sin_addr); + end; + AF_INET6: + begin + result := NetAddrToStr6(sin.sin6_addr); + end; + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +var + x, n: integer; + a4: array [1..255] of in_addr; + a6: array [1..255] of Tin6_addr; + he: THostEntry; +begin + IPList.Clear; + if (family = AF_INET) or (family = AF_UNSPEC) then + begin + if lowercase(name) = cLocalHostStr then + IpList.Add(cLocalHost) + else + begin + a4[1] := StrTonetAddr(name); + if a4[1].s_addr = INADDR_ANY then + if GetHostByName(name, he) then + begin + a4[1]:=HostToNet(he.Addr); + x := 1; + end + else + x := Resolvename(name, a4) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr(a4[n])); + end; + end; + + if (family = AF_INET6) or (family = AF_UNSPEC) then + begin + if lowercase(name) = cLocalHostStr then + IpList.Add(c6LocalHost) + else + begin + a6[1] := StrTonetAddr6(name); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + x := Resolvename6(name, a6) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr6(a6[n])); + end; + end; + + if IPList.Count = 0 then + IPList.Add(cLocalHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: TProtocolEntry; + ServEnt: TServiceEntry; +begin + Result := synsock.htons(StrToIntDef(Port, 0)); + if Result = 0 then + begin + ProtoEnt.Name := ''; + GetProtocolByNumber(SockProtocol, ProtoEnt); + ServEnt.port := 0; + GetServiceByName(Port, ProtoEnt.Name, ServEnt); + Result := ServEnt.port; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + n: integer; + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + a: array [1..1] of string; +begin + Result := IP; + a4[1] := StrToNetAddr(IP); + if a4[1].s_addr <> INADDR_ANY then + begin +//why ResolveAddress need address in HOST order? :-O + n := ResolveAddress(nettohost(a4[1]), a); + if n > 0 then + Result := a[1]; + end + else + begin + a6[1] := StrToNetAddr6(IP); + n := ResolveAddress6(a6[1], a); + if n > 0 then + Result := a[1]; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + SockEnhancedApi := False; + SockWship6Api := False; +// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/ssl_cryptlib.pas b/ssl_cryptlib.pas new file mode 100644 index 0000000..0a7c74f --- /dev/null +++ b/ssl_cryptlib.pas @@ -0,0 +1,681 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.001 | +|==============================================================================| +| Content: SSL/SSH support by Peter Gutmann's CryptLib | +|==============================================================================| +| Copyright (c)1999-2015, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2005-2015. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL/SSH plugin for CryptLib) + +This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32 +and Linux. This library is staticly linked - when you compile your application +with this plugin, you MUST distribute it with Cryptib library, otherwise you +cannot run your application! + +It can work with keys and certificates stored as PKCS#15 only! It must be stored +as disk file only, you cannot load them from memory! Each file can hold multiple +keys and certificates. You must identify it by 'label' stored in +@link(TSSLCryptLib.PrivateKeyLabel). + +If you need to use secure connection and authorize self by certificate +(each SSL/TLS server or client with client authorization), then use +@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and +@link(TCustomSSL.KeyPassword) properties. + +If you need to use server what verifying client certificates, then use +@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients +with non-matching certificates will be rejected by cryptLib. + +This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS +server without explicitly assigned key and certificate, then this plugin create +Ad-Hoc key and certificate for each incomming connection by self. It slowdown +accepting of new connections! + +You can use this plugin for SSHv2 connections too! You must explicitly set +@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username) +and @link(TCustomSSL.password). You can use special SSH channels too, see +@link(TCustomSSL). +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_cryptlib; + +interface + +uses + Windows, + SysUtils, + blcksock, synsock, synautil, synacode, + cryptlib; + +type + {:@abstract(class implementing CryptLib SSL/SSH plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLCryptLib = class(TCustomSSL) + protected + FCryptSession: CRYPT_SESSION; + FPrivateKeyLabel: string; + FDelCert: Boolean; + FReadBuffer: string; + FTrustedCAs: array of integer; + function SSLCheck(Value: integer): Boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; + function CreateSelfSignedCert(Host: string): Boolean; override; + function PopAll: string; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:Load trusted CA's in PEM format} + procedure SetCertCAFile(const Value: string); override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited} + procedure Assign(const Value: TCustomSSL); override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetVerifyCert: integer; override; + published + {:name of certificate/key within PKCS#15 file. It can hold more then one + certificate/key and each certificate/key must have unique label within one file.} + property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel; + end; + +implementation + +{==============================================================================} + +constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + FPrivateKeyLabel := 'synapse'; + FDelCert := false; + FTrustedCAs := nil; +end; + +destructor TSSLCryptLib.Destroy; +begin + SetCertCAFile(''); // destroy certificates + DeInit; + inherited Destroy; +end; + +procedure TSSLCryptLib.Assign(const Value: TCustomSSL); +begin + inherited Assign(Value); + if Value is TSSLCryptLib then + begin + FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel; + end; +end; + +function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; +var + l: integer; +begin + l := 0; + cryptGetAttributeString(cryptHandle, attributeType, nil, l); + setlength(Result, l); + cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l); + setlength(Result, l); +end; + +function TSSLCryptLib.LibVersion: String; +var + x: integer; +begin + Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x); + Result := Result + ' v' + IntToStr(x); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x); + Result := Result + '.' + IntToStr(x); + cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x); + Result := Result + '.' + IntToStr(x); +end; + +function TSSLCryptLib.LibName: String; +begin + Result := 'ssl_cryptlib'; +end; + +function TSSLCryptLib.SSLCheck(Value: integer): Boolean; +begin + Result := true; + FLastErrorDesc := ''; + if Value = CRYPT_ERROR_COMPLETE then + Value := 0; + FLastError := Value; + if FLastError <> 0 then + begin + Result := False; +{$IF CRYPTLIB_VERSION >= 3400} + FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE); +{$ELSE} + FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE); +{$IFEND} + end; +end; + +function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean; +var + privateKey: CRYPT_CONTEXT; + keyset: CRYPT_KEYSET; + cert: CRYPT_CERTIFICATE; + publicKey: CRYPT_CONTEXT; +begin + if FPrivatekeyFile = '' then + FPrivatekeyFile := GetTempFile('', 'key'); + cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA); + cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel), + Length(FPrivatekeyLabel)); + cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024); + cryptGenerateKey(privateKey); + cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE); + FDelCert := True; + cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword)); + cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE); + cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1); + cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel)); + cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey); + cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host)); + cryptSignCert(cert, privateKey); + cryptAddPublicKey(keyset, cert); + cryptKeysetClose(keyset); + cryptDestroyCert(cert); + cryptDestroyContext(privateKey); + cryptDestroyContext(publicKey); + Result := True; +end; + +function TSSLCryptLib.PopAll: string; +const + BufferMaxSize = 32768; +var + Outbuffer: string; + WriteLen: integer; +begin + Result := ''; + repeat + setlength(outbuffer, BufferMaxSize); + Writelen := 0; + SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); + if FLastError <> 0 then + Break; + if WriteLen > 0 then + begin + setlength(outbuffer, WriteLen); + Result := Result + outbuffer; + end; + until WriteLen = 0; +end; + +function TSSLCryptLib.Init(server:Boolean): Boolean; +var + st: CRYPT_SESSION_TYPE; + keysetobj: CRYPT_KEYSET; + cryptContext: CRYPT_CONTEXT; + x: integer; + aUserName : AnsiString; + aPassword: AnsiString; +begin + Result := False; + FLastErrorDesc := ''; + FLastError := 0; + FDelCert := false; + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + if server then + case FSSLType of + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + st := CRYPT_SESSION_SSL_SERVER; + LT_SSHv2: + st := CRYPT_SESSION_SSH_SERVER; + else + Exit; + end + else + case FSSLType of + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + st := CRYPT_SESSION_SSL; + LT_SSHv2: + st := CRYPT_SESSION_SSH; + else + Exit; + end; + if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then + Exit; + x := -1; + case FSSLType of + LT_SSLv3: + x := 0; + LT_TLSv1: + x := 1; + LT_TLSv1_1: + x := 2; + end; + if x >= 0 then + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then + Exit; + + if (FCertComplianceLevel <> -1) then + if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL, + FCertComplianceLevel)) then + Exit; + + if FUsername <> '' then + begin + aUserName := fUserName; + aPassword := fPassword; + cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, + Pointer(FUsername), Length(FUsername)); + cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, + Pointer(FPassword), Length(FPassword)); + end; + if FSSLType = LT_SSHv2 then + if FSSHChannelType <> '' then + begin + cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED); + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE, + Pointer(FSSHChannelType), Length(FSSHChannelType)); + if FSSHChannelArg1 <> '' then + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1, + Pointer(FSSHChannelArg1), Length(FSSHChannelArg1)); + if FSSHChannelArg2 <> '' then + cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2, + Pointer(FSSHChannelArg2), Length(FSSHChannelArg2)); + end; + + + if server and (FPrivatekeyFile = '') then + begin + if FPrivatekeyLabel = '' then + FPrivatekeyLabel := 'synapse'; + if FkeyPassword = '' then + FkeyPassword := 'synapse'; + CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); + end; + + if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then + begin + if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, + PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then + Exit; + try + if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME, + PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then + Exit; + if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY, + cryptcontext)) then + Exit; + finally + cryptKeysetClose(keySetObj); + cryptDestroyContext(cryptcontext); + end; + end; + if server and FVerifyCert then + begin + if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, + PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then + Exit; + try + if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET, + keySetObj)) then + Exit; + finally + cryptKeysetClose(keySetObj); + end; + end; + Result := true; +end; + +function TSSLCryptLib.DeInit: Boolean; +begin + Result := True; + if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then + CryptDestroySession(FcryptSession); + FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); + FSSLEnabled := False; + if FDelCert then + SysUtils.DeleteFile(FPrivatekeyFile); +end; + +function TSSLCryptLib.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLCryptLib.Connect: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(false) then + begin + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then + Exit; + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then + Exit; + if FverifyCert then + if (GetVerifyCert <> 0) or (not DoVerifyCert) then + Exit; + FSSLEnabled := True; + Result := True; + FReadBuffer := ''; + end; +end; + +function TSSLCryptLib.Accept: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(true) then + begin + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then + Exit; + if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then + Exit; + FSSLEnabled := True; + Result := True; + FReadBuffer := ''; + end; +end; + +function TSSLCryptLib.Shutdown: boolean; +begin + Result := BiShutdown; +end; + +function TSSLCryptLib.BiShutdown: boolean; +begin + if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then + cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); + DeInit; + FReadBuffer := ''; + Result := True; +end; + +function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L)); + cryptFlushData(FcryptSession); + Result := l; +end; + +function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + if Length(FReadBuffer) = 0 then + FReadBuffer := PopAll; + if Len > Length(FReadBuffer) then + Len := Length(FReadBuffer); + Move(Pointer(FReadBuffer)^, buffer^, Len); + Delete(FReadBuffer, 1, Len); + Result := Len; +end; + +function TSSLCryptLib.WaitingData: Integer; +begin + Result := Length(FReadBuffer); +end; + +function TSSLCryptLib.GetSSLVersion: string; +var + x: integer; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x); + if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then + case x of + 0: + Result := 'SSLv3'; + 1: + Result := 'TLSv1'; + 2: + Result := 'TLSv1.1'; + end; + if FSSLType in [LT_SSHv2] then + case x of + 0: + Result := 'SSHv1'; + 1: + Result := 'SSHv2'; + end; +end; + +function TSSLCryptLib.GetPeerSubject: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + Result := GetString(cert, CRYPT_CERTINFO_DN); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerName: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerIssuer: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME); + Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); + cryptDestroyCert(cert); +end; + +function TSSLCryptLib.GetPeerFingerprint: string; +var + cert: CRYPT_CERTIFICATE; +begin + Result := ''; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT); + cryptDestroyCert(cert); +end; + + +procedure TSSLCryptLib.SetCertCAFile(const Value: string); + +var F:textfile; + bInCert:boolean; + s,sCert:string; + cert: CRYPT_CERTIFICATE; + idx:integer; + +begin +if assigned(FTrustedCAs) then + begin + for idx := 0 to High(FTrustedCAs) do + cryptDestroyCert(FTrustedCAs[idx]); + FTrustedCAs:=nil; + end; +if Value<>'' then + begin + AssignFile(F,Value); + reset(F); + bInCert:=false; + idx:=0; + while not eof(F) do + begin + readln(F,s); + if pos('-----END CERTIFICATE-----',s)>0 then + begin + bInCert:=false; + cert:=0; + if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then + begin + cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 ); + SetLength(FTrustedCAs,idx+1); + FTrustedCAs[idx]:=cert; + idx:=idx+1; + end; + end; + if bInCert then + sCert:=sCert+s+#13#10; + if pos('-----BEGIN CERTIFICATE-----',s)>0 then + begin + bInCert:=true; + sCert:=''; + end; + end; + CloseFile(F); + end; +end; + +function TSSLCryptLib.GetVerifyCert: integer; +var + cert: CRYPT_CERTIFICATE; + itype,ilocus:integer; +begin + Result := -1; + if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then + Exit; + cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); + result:=cryptCheckCert(cert,CRYPT_UNUSED); + if result<>CRYPT_OK then + begin + //get extended error info if available + cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype); + cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus); + cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); + FLastError := Result; + FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.', + [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]); + end; + cryptDestroyCert(cert); +end; + +{==============================================================================} + +var imajor,iminor,iver:integer; +// e: ESynapseError; + +initialization + if cryptInit = CRYPT_OK then + SSLImplementation := TSSLCryptLib; + cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL); + cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor); + cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor); +// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits + if CRYPTLIB_VERSION >1000 then + iver:=CRYPTLIB_VERSION div 100 + else + iver:=CRYPTLIB_VERSION div 10; + if (iver <> imajor*10+iminor) then + begin + SSLImplementation :=TSSLNone; +// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ', +// [imajor,iminor,iver div 10, iver mod 10])); +// e.ErrorCode := 0; +// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)', +// [imajor,iminor,iver div 10, iver mod 10]); +// raise e; + end; +finalization + cryptEnd; +end. + + diff --git a/ssl_libssh2.pas b/ssl_libssh2.pas new file mode 100644 index 0000000..ef69849 --- /dev/null +++ b/ssl_libssh2.pas @@ -0,0 +1,251 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: SSH support by LibSSH2 | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Alexey Suhinin. | +| Portions created by Alexey Suhinin are Copyright (c)2012-2013. | +| Portions created by Lukas Gebauer are Copyright (c)2013-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +//requires LibSSH2 libraries! http://libssh2.org + +{:@abstract(SSH plugin for LibSSH2) + +Requires libssh2.dll or libssh2.so. +You can download binaries as part of the CURL project from +http://curl.haxx.se/download.html + +You need Pascal bindings for the library too! You can find one at: + http://www.lazarus.freepascal.org/index.php/topic,15935.msg86465.html#msg86465 + +This plugin implements the client part only. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_libssh2; + +interface + +uses + SysUtils, + blcksock, synsock, + libssh2; + +type + {:@abstract(class implementing LibSSH2 SSH plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLLibSSH2 = class(TCustomSSL) + protected + FSession: PLIBSSH2_SESSION; + FChannel: PLIBSSH2_CHANNEL; + function SSHCheck(Value: integer): Boolean; + function DeInit: Boolean; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited} + function Connect: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + published + end; + +implementation + +{==============================================================================} +function TSSLLibSSH2.SSHCheck(Value: integer): Boolean; +var + PLastError: PAnsiChar; + ErrMsgLen: Integer; +begin + Result := true; + FLastError := 0; + FLastErrorDesc := ''; + if Value<0 then + begin + FLastError := libssh2_session_last_error(FSession, PLastError, ErrMsglen, 0); + FLastErrorDesc := PLastError; + Result := false; + end; +end; + + +function TSSLLibSSH2.DeInit: Boolean; +begin + if Assigned(FChannel) then + begin + libssh2_channel_free(FChannel); + FChannel := nil; + end; + if Assigned(FSession) then + begin + libssh2_session_disconnect(FSession,'Goodbye'); + libssh2_session_free(FSession); + FSession := nil; + end; + FSSLEnabled := False; + Result := true; +end; + +constructor TSSLLibSSH2.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FSession := nil; + FChannel := nil; +end; + +destructor TSSLLibSSH2.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLLibSSH2.Connect: boolean; +begin + Result := False; + if SSLEnabled then DeInit; + if (FSocket.Socket <> INVALID_SOCKET) and (FSocket.SSL.SSLType = LT_SSHv2) then + begin + FSession := libssh2_session_init(); + if not Assigned(FSession) then + begin + FLastError := -999; + FLastErrorDesc := 'Cannot initialize SSH session'; + exit; + end; + if not SSHCheck(libssh2_session_startup(FSession, FSocket.Socket)) then + exit; + // Attempt private key authentication, then fall back to username/password but + // do not forget original private key auth error. This avoids giving spurious errors like + // Authentication failed (username/password) + // instead of e.g. + // Unable to extract public key from private key file: Method unimplemented in libgcrypt backend + if FSocket.SSL.PrivateKeyFile<>'' then + if (not SSHCheck(libssh2_userauth_publickey_fromfile(FSession, PChar(FSocket.SSL.Username), nil, PChar(FSocket.SSL.PrivateKeyFile), PChar(FSocket.SSL.KeyPassword)))) + and (libssh2_userauth_password(FSession, PChar(FSocket.SSL.Username), PChar(FSocket.SSL.Password))<0) then + exit; + FChannel := libssh2_channel_open_session(FSession); + if not assigned(FChannel) then + begin +// SSHCheck(-1); + FLastError:=-999; + FLastErrorDesc := 'Cannot open session'; + exit; + end; + if not SSHCheck(libssh2_channel_request_pty(FChannel, 'vanilla')) then + exit; + if not SSHCheck(libssh2_channel_shell(FChannel)) then + exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLLibSSH2.LibName: String; +begin + Result := 'ssl_libssh2'; +end; + +function TSSLLibSSH2.Shutdown: boolean; +begin + Result := DeInit; +end; + + +function TSSLLibSSH2.BiShutdown: boolean; +begin + Result := DeInit; +end; + +function TSSLLibSSH2.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + Result:=libssh2_channel_write(FChannel, PAnsiChar(Buffer), Len); + SSHCheck(Result); +end; + +function TSSLLibSSH2.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + result:=libssh2_channel_read(FChannel, PAnsiChar(Buffer), Len); + SSHCheck(Result); +end; + +function TSSLLibSSH2.WaitingData: Integer; +begin + if libssh2_poll_channel_read(FChannel, Result) <> 1 then + Result := 0; +end; + +function TSSLLibSSH2.GetSSLVersion: string; +begin + Result := 'SSH2'; +end; + +function TSSLLibSSH2.LibVersion: String; +begin + Result := libssh2_version(0); +end; + +initialization + if libssh2_init(0)=0 then + SSLImplementation := TSSLLibSSH2; + +finalization + libssh2_exit; + +end. diff --git a/ssl_openssl.pas b/ssl_openssl.pas new file mode 100644 index 0000000..4465eee --- /dev/null +++ b/ssl_openssl.pas @@ -0,0 +1,1007 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| Copyright (c)1999-2017, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2005-2017. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +//requires OpenSSL libraries! + +{:@abstract(SSL plugin for OpenSSL) + +Compatibility with OpenSSL versions: +0.9.6 should work, known mysterious crashing on FreePascal and Linux platform. +0.9.7 - 1.0.0 working fine. +1.1.0 should work, under testing. + +OpenSSL libraries are loaded dynamicly - you not need OpenSSL librares even you +compile your application with this unit. SSL just not working when you not have +OpenSSL libraries. + +This plugin have limited support for .NET too! Because is not possible to use +callbacks with CDECL calling convention under .NET, is not supported +key/certificate passwords and multithread locking. :-( + +For handling keys and certificates you can use this properties: + +@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br +@link(TCustomSSL.Certificate) for ASN1 DER format only. @br +@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br +@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br +@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br +@link(TCustomSSL.PFXFile) for PFX format. @br +@link(TCustomSSL.PFX) for PFX format from binary string. @br + +This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS +server without explicitly assigned key and certificate, then this plugin create +Ad-Hoc key and certificate for each incomming connection by self. It slowdown +accepting of new connections! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ssl_openssl; + +interface + +uses + SysUtils, Classes, + blcksock, synsock, synautil, + synabyte, +{$IFDEF CIL} + System.Text, +{$ENDIF} + ssl_openssl_lib; + +type + {:@abstract(class implementing OpenSSL SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLOpenSSL = class(TCustomSSL) + protected + FSsl: PSSL; + Fctx: PSSL_CTX; + function SSLCheck: Boolean; + function SetSslKeys: boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + function LoadPFX(pfxdata: TSynaBytes): Boolean; + function CreateSelfSignedCert(Host: string): Boolean; override; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_cryptlib) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerSerialNo: integer; override; {pf} + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerNameHash: cardinal; override; {pf} + {:See @inherited} + function GetPeerFingerprint: string; override; + function GetPeerFingerprintDigest(const ADigest: string): string; override; + {:See @inherited} + function GetCertInfo: string; override; + {:See @inherited} + function GetCipherName: string; override; + {:See @inherited} + function GetCipherBits: integer; override; + {:See @inherited} + function GetCipherAlgBits: integer; override; + {:See @inherited} + function GetVerifyCert: integer; override; + end; + +implementation + +{==============================================================================} + +{$IFNDEF CIL} +function PasswordCallback(Buf:PByte; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; +var + Password: TSynabytes; +begin + Password := ''; + if TCustomSSL(userdata) is TCustomSSL then + Password := TCustomSSL(userdata).KeyPassword; + if Length(Password) > (Size - 1) then + {$IFDEF UNICODE} + Password.Length := Size - 1; + {$ELSE} + SetLength(Password, Size - 1); + {$ENDIF} + Result := Length(Password); + Password := Password + #0; + +{$IFDEF UNICODE} + Move(Password.Data^, buf^, result+1); +{$ELSE} + Move(PAnsiChar(AnsiString(Password))^, buf^, result+1); +{$ENDIF} +end; +{$ENDIF} + +{==============================================================================} + +constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FCiphers := 'DEFAULT'; + FSsl := nil; + Fctx := nil; +end; + +destructor TSSLOpenSSL.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLOpenSSL.LibVersion: String; +begin + Result := SSLeayversion(0); +end; + +function TSSLOpenSSL.LibName: String; +begin + Result := 'ssl_openssl'; +end; + +function TSSLOpenSSL.SSLCheck: Boolean; +var +{$IFDEF CIL} + sb: StringBuilder; +{$ELSE} + se: integer; +{$ENDIF} + s : TSynabytes; +begin + Result := true; + FLastErrorDesc := ''; + FLastError := ErrGetError; + ErrClearError; + if FLastError <> 0 then + begin + Result := False; +{$IFDEF CIL} + sb := StringBuilder.Create(256); + ErrErrorString(FLastError, sb, 256); + FLastErrorDesc := Trim(sb.ToString); +{$ELSE} + //{$IFDEF WIN???} + if FLastError = SSL_ERROR_SYSCALL then + begin + se := WSAGetLastError(); + FLastErrorDesc := '#sslErr:' + SysUtils.IntToStr(FLastError) + + ' #sysErr:' + SysUtils.IntToStr(se) + + ' ' + string(TBlockSocket.GetErrorDesc(se)) // cast + end; + //{$ELSE} + //{$ENDIF} + if FLastErrorDesc = '' then + begin + s := StringOfChar(AnsiChar(#0), 256); + ErrErrorString(FLastError, s, Length(s)); + FLastErrorDesc := '#sslErr:' + SysUtils.IntToStr(FLastError) + + ' ' + string(s); // cast + end +{$ENDIF} + end; +end; + +function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean; +var + pk: EVP_PKEY; + x: PX509; + rsa: PRSA; + t: PASN1_UTCTIME; + name: PX509_NAME; + b: PBIO; + xn, y: integer; + s: TBytes; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + Result := True; + pk := EvpPkeynew; + x := X509New; + try + rsa := RsaGenerateKey(1024, $10001, nil, nil); + EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); + X509SetVersion(x, 2); + Asn1IntegerSet(X509getSerialNumber(x), 0); + t := Asn1UtctimeNew; + try + X509GmtimeAdj(t, -60 * 60 *24); + X509SetNotBefore(x, t); + X509GmtimeAdj(t, 60 * 60 * 60 *24); + X509SetNotAfter(x, t); + finally + Asn1UtctimeFree(t); + end; + X509SetPubkey(x, pk); + Name := X509GetSubjectName(x); + X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0); + X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0); + x509SetIssuerName(x, Name); + x509Sign(x, pk, EvpGetDigestByName('SHA1')); + b := BioNew(BioSMem); + try + i2dX509Bio(b, x); + xn := bioctrlpending(b); +{$IFDEF CIL} + sb := StringBuilder.Create(xn); + y := bioread(b, sb, xn); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; +{$ELSE} + setlength(s, xn); + y := bioread(b, @s[0], xn); + if y > 0 then + setlength(s, y); +{$ENDIF} + finally + BioFreeAll(b); + end; + FCertificate := StringOf(s); + b := BioNew(BioSMem); + try + i2dPrivatekeyBio(b, pk); + xn := bioctrlpending(b); +{$IFDEF CIL} + sb := StringBuilder.Create(xn); + y := bioread(b, sb, xn); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; +{$ELSE} + setlength(s, xn); + y := bioread(b, @s[0], xn); + if y > 0 then + setlength(s, y); +{$ENDIF} + finally + BioFreeAll(b); + end; + FPrivatekey := StringOf(s); + finally + X509free(x); + EvpPkeyFree(pk); + end; +end; + +function TSSLOpenSSL.LoadPFX(pfxdata: TSynaBytes): Boolean; +var + cert, pkey, ca: SslPtr; + b: PBIO; + p12: SslPtr; + buf: PByte; + len: cardinal; +begin + Result := False; + b := BioNew(BioSMem); + try +{$IFDEF UNICODE} + buf := pfxdata.Data; + len := pfxdata.Length; +{$ELSE} + buf := PByte(pfxData); + len := length(pfxData); +{$ENDIF} + BioWrite(b, buf, len); + p12 := d2iPKCS12bio(b, nil); + if not Assigned(p12) then + Exit; + try + cert := nil; + pkey := nil; + ca := nil; + try {pf} + if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then + if SSLCTXusecertificate(Fctx, cert) > 0 then + if SSLCTXusePrivateKey(Fctx, pkey) > 0 then + Result := True; + {pf} + finally + EvpPkeyFree(pkey); + X509free(cert); + SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated... + end; + {/pf} + finally + PKCS12free(p12); + end; + finally + BioFreeAll(b); + end; +end; + +function TSSLOpenSSL.SetSslKeys: boolean; +var + st: TFileStream; + s: string; +begin + Result := False; + if not assigned(FCtx) then + Exit; + try + if FCertificateFile <> '' then + if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then + if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then + if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then + Exit; + if FCertificate <> '' then + if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then + Exit; + SSLCheck; + if FPrivateKeyFile <> '' then + if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then + if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then + Exit; + if FPrivateKey <> '' then + if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then + Exit; + SSLCheck; + if FCertCAFile <> '' then + if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then + Exit; + if FPFXfile <> '' then + begin + try + st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone); + try + s := ReadStrFromStream(st, st.Size); + finally + st.Free; + end; + if not LoadPFX(s) then + Exit; + except + on Exception do + Exit; + end; + end; + if FPFX <> '' then + if not LoadPFX(FPfx) then + Exit; + SSLCheck; + Result := True; + finally + SSLCheck; + end; +end; + +function TSSLOpenSSL.Init(server:Boolean): Boolean; +var + s: TSynabytes; + buf: PByte; +begin + Result := False; + FLastErrorDesc := ''; + FLastError := 0; + Fctx := nil; + case FSSLType of + LT_SSLv2: + Fctx := SslCtxNew(SslMethodV2); + LT_SSLv3: + Fctx := SslCtxNew(SslMethodV3); + LT_TLSv1: + Fctx := SslCtxNew(SslMethodTLSV1); + LT_TLSv1_1: + Fctx := SslCtxNew(SslMethodTLSV11); + LT_TLSv1_2: + Fctx := SslCtxNew(SslMethodTLSV12); + LT_all: + begin + //try new call for OpenSSL 1.1.0 first + Fctx := SslCtxNew(SslMethodTLS); + if Fctx=nil then + //callback to previous versions + Fctx := SslCtxNew(SslMethodV23); + end; + else + Exit; + end; + if Fctx = nil then + begin + SSLCheck; + Exit; + end + else + begin + s := FCiphers; + {$IFDEF UNICODE} + buf := s.Data; + {$ELSE} + buf := PByte(s); + {$ENDIF} + SslCtxSetCipherList(Fctx, buf); + if FVerifyCert then + SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) + else + SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); +{$IFNDEF CIL} + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); +{$ENDIF} + + if server and (FCertificateFile = '') and (FCertificate = '') + and (FPFXfile = '') and (FPFX = '') then + begin + CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); + end; + + if not SetSSLKeys then + Exit + else + begin + Fssl := nil; + Fssl := SslNew(Fctx); + if Fssl = nil then + begin + SSLCheck; + exit; + end; + end; + end; + Result := true; +end; + +function TSSLOpenSSL.DeInit: Boolean; +begin + Result := True; + if assigned (Fssl) then + sslfree(Fssl); + Fssl := nil; + if assigned (Fctx) then + begin + SslCtxFree(Fctx); + Fctx := nil; + ErrRemoveState(0); + end; + FSSLEnabled := False; +end; + +function TSSLOpenSSL.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLOpenSSL.Connect: boolean; +var + x: integer; + b: boolean; + err: integer; + s: TSynabytes; + buf: PByte; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(False) then + begin +{$IFDEF CIL} + if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then +{$ELSE} + if sslsetfd(FSsl, FSocket.Socket) < 1 then +{$ENDIF} + begin + SSLCheck; + Exit; + end; + if SNIHost<>'' then + begin + s := sniHost; + {$IFDEF UNICODE} + buf := s.Data; + {$ELSE} + buf := PByte(s); + {$ENDIF} + SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, buf); + end; + if FSocket.ConnectionTimeout <= 0 then //do blocking call of SSL_Connect + begin + x := sslconnect(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + end + else //do non-blocking call of SSL_Connect + begin + b := Fsocket.NonBlockMode; + Fsocket.NonBlockMode := true; + repeat + x := sslconnect(FSsl); + err := SslGetError(FSsl, x); + if err = SSL_ERROR_WANT_READ then + if not FSocket.CanRead(FSocket.ConnectionTimeout) then + break; + if err = SSL_ERROR_WANT_WRITE then + if not FSocket.CanWrite(FSocket.ConnectionTimeout) then + break; + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + Fsocket.NonBlockMode := b; + if err <> SSL_ERROR_NONE then + begin + SSLcheck; + Exit; + end; + end; + if FverifyCert then + if (GetVerifyCert <> 0) or (not DoVerifyCert) then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL.Accept: boolean; +var + x: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(True) then + begin +{$IFDEF CIL} + if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then +{$ELSE} + if sslsetfd(FSsl, FSocket.Socket) < 1 then +{$ENDIF} + begin + SSLCheck; + Exit; + end; + x := sslAccept(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL.Shutdown: boolean; +begin + if assigned(FSsl) then + sslshutdown(FSsl); + DeInit; + Result := True; +end; + +function TSSLOpenSSL.BiShutdown: boolean; +var + x: integer; +begin + if assigned(FSsl) then + begin + x := sslshutdown(FSsl); + if x = 0 then + begin + Synsock.Shutdown(FSocket.Socket, 1); + sslshutdown(FSsl); + end; + end; + DeInit; + Result := True; +end; + +function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +{$IFDEF CIL} + s: ansistring; +{$ENDIF} +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat +{$IFDEF CIL} + s := StringOf(Buffer); + Result := SslWrite(FSsl, s, Len); +{$ELSE} + Result := SslWrite(FSsl, Buffer , Len); +{$ENDIF} + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + else + if (err <> 0) then + FLastError := err; +end; + +function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +{$IFDEF CIL} + sb: stringbuilder; + s: ansistring; +{$ENDIF} +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat +{$IFDEF CIL} + sb := StringBuilder.Create(Len); + Result := SslRead(FSsl, sb, Len); + if Result > 0 then + begin + sb.Length := Result; + s := sb.ToString; + System.Array.Copy(BytesOf(s), Buffer, length(s)); + end; +{$ELSE} + Result := SslRead(FSsl, Buffer , Len); +{$ENDIF} + err := SslGetError(FSsl, Result); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + Result := 0 + {pf}// Verze 1.1.0 byla s else tak jak to ted mam, + // ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN + // propagovano jako Chyba. + {pf} else {/pf} if (err <> 0) then + FLastError := err; +end; + +function TSSLOpenSSL.WaitingData: Integer; +begin + Result := sslpending(Fssl); +end; + +function TSSLOpenSSL.GetSSLVersion: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SSlGetVersion(FSsl); +end; + +function TSSLOpenSSL.GetPeerSubject: string; +var + cert: PX509; + s: TBytes; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096); +{$ELSE} + setlength(s, 4096); + Result := X509NameOneline(X509GetSubjectName(cert), @s[0], Length(s)); +{$ENDIF} + X509Free(cert); +end; + + +function TSSLOpenSSL.GetPeerSerialNo: integer; {pf} +var + cert: PX509; + SN: PASN1_INTEGER; +begin + if not assigned(FSsl) then + begin + Result := -1; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := -1; + Exit; + end; + SN := X509GetSerialNumber(cert); + Result := Asn1IntegerGet(SN); + finally + X509Free(cert); + end; +end; + +function TSSLOpenSSL.GetPeerName: string; +var + s: string; +begin + s := GetPeerSubject; + s := SeparateRight(s, '/CN='); + Result := Trim(SeparateLeft(s, '/')); +end; + +function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf} +var + cert: PX509; +begin + if not assigned(FSsl) then + begin + Result := 0; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + try + if not assigned(cert) then + begin + Result := 0; + Exit; + end; + Result := X509NameHash(X509GetSubjectName(cert)); + finally + X509Free(cert); + end; +end; + +function TSSLOpenSSL.GetPeerIssuer: string; +var + cert: PX509; + s: TBytes; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096); +{$ELSE} + setlength(s, 4096); + Result := X509NameOneline(X509GetIssuerName(cert), @s[0], Length(s)); +{$ENDIF} + X509Free(cert); +end; + +function TSSLOpenSSL.GetPeerFingerprint: string; +var + cert: PX509; + x: integer; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; +{$IFDEF CIL} + sb := StringBuilder.Create(EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('MD5'), sb, x); + sb.Length := x; + Result := sb.ToString; +{$ELSE} + setlength(Result, EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('MD5'), Result, x); + SetLength(Result, x); +{$ENDIF} + X509Free(cert); +end; + +function TSSLOpenSSL.GetPeerFingerprintDigest(const ADigest: string): string; +var + cert: PX509; + x: integer; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(Result, 128); + X509Digest(cert, EvpGetDigestByName(ADigest), Result, x); + SetLength(Result, x); + X509Free(cert); +end; + +function TSSLOpenSSL.GetCertInfo: string; +var + cert: PX509; + x, y: integer; + b: PBIO; + s: TBytes; +{$IFDEF CIL} + sb: stringbuilder; +{$ENDIF} +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + try {pf} + b := BioNew(BioSMem); + try + X509Print(b, cert); + x := bioctrlpending(b); + {$IFDEF CIL} + sb := StringBuilder.Create(x); + y := bioread(b, sb, x); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; + {$ELSE} + setlength(s,x); + y := bioread(b,@s[0],x); + if y > 0 then + setlength(s, y); + {$ENDIF} + Result := ReplaceString(StringOf(s), LF, CRLF); + finally + BioFreeAll(b); + end; + {pf} + finally + X509Free(cert); + end; + {/pf} +end; + +function TSSLOpenSSL.GetCipherName: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); +end; + +function TSSLOpenSSL.GetCipherBits: integer; +var + x: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); +end; + +function TSSLOpenSSL.GetCipherAlgBits: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); +end; + +function TSSLOpenSSL.GetVerifyCert: integer; +begin + if not assigned(FSsl) then + Result := 1 + else + Result := SslGetVerifyResult(FSsl); +end; + +{==============================================================================} + +initialization + if InitSSLInterface then + SSLImplementation := TSSLOpenSSL; + +end. diff --git a/ssl_openssl_lib.pas b/ssl_openssl_lib.pas new file mode 100644 index 0000000..e6696b5 --- /dev/null +++ b/ssl_openssl_lib.pas @@ -0,0 +1,2463 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.008.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| Copyright (c)1999-2017, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2002-2017. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{ +Special thanks to Gregor Ibic + (Intelicom d.o.o., http://www.intelicom.si) + for good inspiration about begin with SSL programming. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *) +{$ENDIF} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{:@abstract(OpenSSL support) + +This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit). +OpenSSL is loaded dynamicly on-demand. If this library is not found in system, +requested OpenSSL function just return errorcode. +} +unit ssl_openssl_lib; + +interface + +{$IFDEF IOS} +{$DEFINE STATIC} +{$ENDIF} + +uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} + Classes, + synafpc, + synabyte, +{$IFNDEF MSWINDOWS} + {$IFDEF FPC} + {$IFDEF UNIX} + BaseUnix, + {$ENDIF UNIX} + {$ELSE} + Libc, + {$ENDIF} + SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +{$IFDEF CIL} +const + {$IFDEF LINUX} + DLLSSLName = 'libssl.so'; + DLLUtilName = 'libcrypto.so'; + {$ELSE} + DLLSSLName = 'ssleay32.dll'; + DLLUtilName = 'libeay32.dll'; + {$ENDIF} +{$ELSE} +var + {$IFNDEF MSWINDOWS} + {$IFDEF DARWIN} + DLLSSLName: string = 'libssl.dylib'; + DLLUtilName: string = 'libcrypto.dylib'; + {$ELSE} + {$IFDEF OS2} + {$IFDEF OS2GCC} + DLLSSLName: string = 'kssl.dll'; + DLLUtilName: string = 'kcrypto.dll'; + {$ELSE OS2GCC} + DLLSSLName: string = 'ssl.dll'; + DLLUtilName: string = 'crypto.dll'; + {$ENDIF OS2GCC} + {$ELSE OS2} + DLLSSLName: string = 'libssl.so'; + DLLUtilName: string = 'libcrypto.so'; + {$ENDIF OS2} + {$ENDIF} + {$ELSE} + DLLSSLName: string = 'ssleay32.dll'; + DLLSSLName2: string = 'libssl32.dll'; + DLLUtilName: string = 'libeay32.dll'; + + DLL_LIBCRYPTO_1_1: string = 'libcrypto-1_1.dll'; + DLL_LIBSSL_1_1: string = 'libssl-1_1.dll'; + + {$ENDIF} +{$ENDIF} + +type +{$IFDEF CIL} + SslPtr = IntPtr; +{$ELSE} + SslPtr = Pointer; +{$ENDIF} + PSslPtr = ^SslPtr; + PSSL_CTX = SslPtr; + PSSL = SslPtr; + PSSL_METHOD = SslPtr; + PX509 = SslPtr; + PX509_NAME = SslPtr; + PEVP_MD = SslPtr; + PInteger = ^Integer; + PBIO_METHOD = SslPtr; + PBIO = SslPtr; + EVP_PKEY = SslPtr; + PRSA = SslPtr; + PASN1_UTCTIME = SslPtr; + PASN1_INTEGER = SslPtr; + PPasswdCb = SslPtr; + PFunction = procedure; + PSTACK = SslPtr; {pf} + TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf} + TX509Free = procedure(x: PX509); cdecl; {pf} + + DES_cblock = array[0..7] of Byte; + PDES_cblock = ^DES_cblock; + des_ks_struct = packed record + ks: DES_cblock; + weak_key: Integer; + end; + des_key_schedule = array[1..16] of des_ks_struct; + +const + EVP_MAX_MD_SIZE = 16 + 20; + + SSL_ERROR_NONE = 0; + SSL_ERROR_SSL = 1; + SSL_ERROR_WANT_READ = 2; + SSL_ERROR_WANT_WRITE = 3; + SSL_ERROR_WANT_X509_LOOKUP = 4; + SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno + SSL_ERROR_ZERO_RETURN = 6; + SSL_ERROR_WANT_CONNECT = 7; + SSL_ERROR_WANT_ACCEPT = 8; + + SSL_OP_NO_SSLv2 = $01000000; + SSL_OP_NO_SSLv3 = $02000000; + SSL_OP_NO_TLSv1 = $04000000; + SSL_OP_ALL = $000FFFFF; + SSL_VERIFY_NONE = $00; + SSL_VERIFY_PEER = $01; + + OPENSSL_DES_DECRYPT = 0; + OPENSSL_DES_ENCRYPT = 1; + + X509_V_OK = 0; + X509_V_ILLEGAL = 1; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2; + X509_V_ERR_UNABLE_TO_GET_CRL = 3; + X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4; + X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5; + X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6; + X509_V_ERR_CERT_SIGNATURE_FAILURE = 7; + X509_V_ERR_CRL_SIGNATURE_FAILURE = 8; + X509_V_ERR_CERT_NOT_YET_VALID = 9; + X509_V_ERR_CERT_HAS_EXPIRED = 10; + X509_V_ERR_CRL_NOT_YET_VALID = 11; + X509_V_ERR_CRL_HAS_EXPIRED = 12; + X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13; + X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14; + X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15; + X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16; + X509_V_ERR_OUT_OF_MEM = 17; + X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18; + X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19; + X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20; + X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21; + X509_V_ERR_CERT_CHAIN_TOO_LONG = 22; + X509_V_ERR_CERT_REVOKED = 23; + X509_V_ERR_INVALID_CA = 24; + X509_V_ERR_PATH_LENGTH_EXCEEDED = 25; + X509_V_ERR_INVALID_PURPOSE = 26; + X509_V_ERR_CERT_UNTRUSTED = 27; + X509_V_ERR_CERT_REJECTED = 28; + //These are 'informational' when looking for issuer cert + X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29; + X509_V_ERR_AKID_SKID_MISMATCH = 30; + X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31; + X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32; + X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33; + X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34; + //The application is not happy + X509_V_ERR_APPLICATION_VERIFICATION = 50; + + SSL_FILETYPE_ASN1 = 2; + SSL_FILETYPE_PEM = 1; + EVP_PKEY_RSA = 6; + + SSL_CTRL_SET_TLSEXT_HOSTNAME = 55; + TLSEXT_NAMETYPE_host_name = 0; + +var + SSLLibHandle: TLibHandle = 0; + SSLUtilHandle: TLibHandle = 0; + SSLLibFile: string = ''; + SSLUtilFile: string = ''; + +{$IFDEF CIL} + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_error')] + function SslGetError(s: PSSL; ret_code: Integer): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_library_init')] + function SslLibraryInit: Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_load_error_strings')] + procedure SslLoadErrorStrings; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_cipher_list')] + function SslCtxSetCipherList(arg0: PSSL_CTX; var str: string): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_new')] + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_free')] + procedure SslCtxFree (arg0: PSSL_CTX); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_set_fd')] + function SslSetFd(s: PSSL; fd: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv2_method')] + function SslMethodV2 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv3_method')] + function SslMethodV3 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLSv1_method')] + function SslMethodTLSV1:PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLSv1_1_method')] + function SslMethodTLSV11:PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLSv1_2_method')] + function SslMethodTLSV12:PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv23_method')] + function SslMethodV23 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLS_method')] + function SslMethodTLS : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey')] + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')] + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: string; len: integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')] + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: string; _type: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate')] + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_ASN1')] + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: string):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_file')] + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: string; _type: Integer):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_chain_file')] + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: string):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_check_private_key')] + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb')] + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')] + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_load_verify_locations')] + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: string):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_ctrl')] + function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_new')] + function SslNew(ctx: PSSL_CTX):PSSL; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_free')] + procedure SslFree(ssl: PSSL); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_accept')] + function SslAccept(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_connect')] + function SslConnect(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_shutdown')] + function SslShutdown(s: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_read')] + function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_peek')] + function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_write')] + function SslWrite(ssl: PSSL; buf: string; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_pending')] + function SslPending(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_version')] + function SslGetVersion(ssl: PSSL):string; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_peer_certificate')] + function SslGetPeerCertificate(s: PSSL):PX509; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_verify')] + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_current_cipher')] + function SSLGetCurrentCipher(s: PSSL): SslPtr; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_name')] + function SSLCipherGetName(c: SslPtr):string; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_bits')] + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_verify_result')] + function SSLGetVerifyResult(ssl: PSSL):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_ctrl')] + function SslCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: IntPtr): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_new')] + function X509New: PX509; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_free')] + procedure X509Free(x: PX509); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_oneline')] + function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): string; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_subject_name')] + function X509GetSubjectName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_issuer_name')] + function X509GetIssuerName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_hash')] + function X509NameHash(x: PX509_NAME):Cardinal; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_digest')] + function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_version')] + function X509SetVersion(x: PX509; version: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_pubkey')] + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_issuer_name')] + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_add_entry_by_txt')] + function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; + bytes: string; len, loc, _set: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_sign')] + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_print')] + function X509print(b: PBIO; a: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_gmtime_adj')] + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notBefore')] + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_set_notAfter')] + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_serialNumber')] + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_new')] + function EvpPkeyNew: EVP_PKEY; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_free')] + procedure EvpPkeyFree(pk: EVP_PKEY); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_PKEY_assign')] + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_get_digestbyname')] + function EvpGetDigestByName(Name: string): PEVP_MD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_cleanup')] + procedure EVPcleanup; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLeay_version')] + function SSLeayversion(t: integer): string; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_error_string_n')] + procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_get_error')] + function ErrGetError: integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_clear_error')] + procedure ErrClearError; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_free_strings')] + procedure ErrFreeStrings; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_remove_state')] + procedure ErrRemoveState(pid: integer); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'OPENSSL_add_all_algorithms_noconf')] + procedure OPENSSLaddallalgorithms; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'CRYPTO_cleanup_all_ex_data')] + procedure CRYPTOcleanupAllExData; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RAND_screen')] + procedure RandScreen; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_new')] + function BioNew(b: PBIO_METHOD): PBIO; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_free_all')] + procedure BioFreeAll(b: PBIO); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_s_mem')] + function BioSMem: PBIO_METHOD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_ctrl_pending')] + function BioCtrlPending(b: PBIO): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_read')] + function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_write')] + function BioWrite(b: PBIO; var Buf: string; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'd2i_PKCS12_bio')] + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_parse')] + function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'PKCS12_free')] + procedure PKCS12free(p12: SslPtr); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RSA_generate_key')] + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_new')] + function Asn1UtctimeNew: PASN1_UTCTIME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_UTCTIME_free')] + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ASN1_INTEGER_set')] + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_X509_bio')] + function i2dX509bio(b: PBIO; x: PX509): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'i2d_PrivateKey_bio')] + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external; + + // 3DES functions + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_odd_parity')] + procedure DESsetoddparity(Key: des_cblock); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_key_checked')] + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_ecb_encrypt')] + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external; + +{$ELSE} +// libssl.dll + function SslGetError(s: PSSL; ret_code: Integer):Integer; + function SslLibraryInit:Integer; + procedure SslLoadErrorStrings; +// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; + function SslCtxSetCipherList(arg0: PSSL_CTX; str: PByte):Integer; + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; + procedure SslCtxFree(arg0: PSSL_CTX); + function SslSetFd(s: PSSL; fd: Integer):Integer; + function SslMethodV2:PSSL_METHOD; + function SslMethodV3:PSSL_METHOD; + function SslMethodTLSV1:PSSL_METHOD; + function SslMethodTLSV11:PSSL_METHOD; + function SslMethodTLSV12:PSSL_METHOD; + function SslMethodV23:PSSL_METHOD; + function SslMethodTLS:PSSL_METHOD; + function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; + function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: TSynaBytes; len: integer):Integer; +// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer; + function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; + function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: TSynaBytes):Integer; + function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer; +// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: TSynaBytes):Integer; + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); +// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: TSynaBytes; const CApath: TSynaBytes):Integer; + function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; + function SslNew(ctx: PSSL_CTX):PSSL; + procedure SslFree(ssl: PSSL); + function SslAccept(ssl: PSSL):Integer; + function SslConnect(ssl: PSSL):Integer; + function SslShutdown(ssl: PSSL):Integer; + function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslPending(ssl: PSSL):Integer; + function SslGetVersion(ssl: PSSL):string; + function SslGetPeerCertificate(ssl: PSSL):PX509; + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); + function SSLGetCurrentCipher(s: PSSL):SslPtr; + function SSLCipherGetName(c: SslPtr): string; + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; + function SSLGetVerifyResult(ssl: PSSL):Integer; + function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; + +// libeay.dll + function X509New: PX509; + procedure X509Free(x: PX509); + function X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer): string; + function X509GetSubjectName(a: PX509):PX509_NAME; + function X509GetIssuerName(a: PX509):PX509_NAME; + function X509NameHash(x: PX509_NAME):Cardinal; +// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; + function X509Digest(data: PX509; _type: PEVP_MD; md: TSynaBytes; var len: Integer):Integer; + function X509print(b: PBIO; a: PX509): integer; + function X509SetVersion(x: PX509; version: integer): integer; + function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; + function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; + function X509NameAddEntryByTxt(name: PX509_NAME; field: TSynaBytes; _type: integer; + bytes: TSynaBytes; len, loc, _set: integer): integer; + function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; + function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; + function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; + function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; + function X509GetSerialNumber(x: PX509): PASN1_INTEGER; + function EvpPkeyNew: EVP_PKEY; + procedure EvpPkeyFree(pk: EVP_PKEY); + function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; + function EvpGetDigestByName(Name: TSynaBytes): PEVP_MD; + procedure EVPcleanup; +// function ErrErrorString(e: integer; buf: PChar): PChar; + function SSLeayversion(t: integer): string; + function OpenSSLversion(t: integer): string; + procedure ErrErrorString(e: integer; var buf: TSynaBytes; len: integer); + function ErrGetError: integer; + procedure ErrClearError; + procedure ErrFreeStrings; + procedure ErrRemoveState(pid: integer); + procedure OPENSSLaddallalgorithms; + procedure CRYPTOcleanupAllExData; + procedure RandScreen; + function BioNew(b: PBIO_METHOD): PBIO; + procedure BioFreeAll(b: PBIO); + function BioSMem: PBIO_METHOD; + function BioCtrlPending(b: PBIO): integer; + function BioRead(b: PBIO; Buf: PByte; Len: integer): integer; + function BioWrite(b: PBIO; Buf: PByte; Len: integer): integer; + function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; + function PKCS12parse(p12: SslPtr; pass: TSynaBytes; var pkey, cert, ca: SslPtr): integer; + procedure PKCS12free(p12: SslPtr); + function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; + function Asn1UtctimeNew: PASN1_UTCTIME; + procedure Asn1UtctimeFree(a: PASN1_UTCTIME); + function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; + function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} + function i2dX509bio(b: PBIO; x: PX509): integer; + function d2iX509bio(b:PBIO; x:PX509): PX509; {pf} + function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} + procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf} + + + function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; + + // 3DES functions + procedure DESsetoddparity(Key: des_cblock); + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); + +{$ENDIF} + +function IsSSLloaded: Boolean; +function InitSSLInterface: Boolean; +function DestroySSLInterface: Boolean; + +var + _X509Free: TX509Free = nil; {pf} + +implementation + +uses +{$IFDEF OS2} + Sockets, +{$ENDIF OS2} + SyncObjs; + +{$IFNDEF CIL} + +{$IFNDEF STATIC} +type +// libssl.dll + TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; + TSslLibraryInit = function:Integer; cdecl; + TSslLoadErrorStrings = procedure; cdecl; + TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PByte):Integer; cdecl; + TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl; + TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl; + TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl; + TSslMethodV2 = function:PSSL_METHOD; cdecl; + TSslMethodV3 = function:PSSL_METHOD; cdecl; + TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; + TSslMethodTLSV11 = function:PSSL_METHOD; cdecl; + TSslMethodTLSV12 = function:PSSL_METHOD; cdecl; + TSslMethodV23 = function:PSSL_METHOD; cdecl; + TSslMethodTLS = function:PSSL_METHOD; cdecl; + TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl; + TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl; + TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl; + TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl; + TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl; + TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl; + TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PByte):Integer; cdecl; + TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; + TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl; + TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl; + TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PByte; const CApath: PByte):Integer; cdecl; + TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl; + TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; + TSslFree = procedure(ssl: PSSL); cdecl; + TSslAccept = function(ssl: PSSL):Integer; cdecl; + TSslConnect = function(ssl: PSSL):Integer; cdecl; + TSslShutdown = function(ssl: PSSL):Integer; cdecl; + TSslRead = function(ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl; + TSslPeek = function(ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl; + TSslWrite = function(ssl: PSSL; const buf: PByte; num: Integer):Integer; cdecl; + TSslPending = function(ssl: PSSL):Integer; cdecl; + TSslGetVersion = function(ssl: PSSL):PByte; cdecl; + TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; + TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl; + TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl; + TSSLCipherGetName = function(c: Sslptr):PByte; cdecl; + TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl; + TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; + TSSLCtrl = function(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl; + + TSSLSetTlsextHostName = function(ssl: PSSL; buf: PAnsiChar):Integer; cdecl; + +// libeay.dll + TX509New = function: PX509; cdecl; + TX509NameOneline = function(a: PX509_NAME; buf: PByte; size: Integer):PByte; cdecl; + TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; + TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; + TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; + TX509Digest = function(data: PX509; _type: PEVP_MD; md: PByte; len: PInteger):Integer; cdecl; + TX509print = function(b: PBIO; a: PX509): integer; cdecl; + TX509SetVersion = function(x: PX509; version: integer): integer; cdecl; + TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl; + TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl; + TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PByte; _type: integer; + bytes: PByte; len, loc, _set: integer): integer; cdecl; + TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl; + TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl; + TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; + TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl; + TEvpPkeyNew = function: EVP_PKEY; cdecl; + TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl; + TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl; + TEvpGetDigestByName = function(Name: PByte): PEVP_MD; cdecl; + TEVPcleanup = procedure; cdecl; + TSSLeayversion = function(t: integer): PByte; cdecl; + TOpenSSLversion = function(t: integer): PByte; cdecl; + TErrErrorString = procedure(e: integer; buf: PByte; len: integer); cdecl; + TErrGetError = function: integer; cdecl; + TErrClearError = procedure; cdecl; + TErrFreeStrings = procedure; cdecl; + TErrRemoveState = procedure(pid: integer); cdecl; + TOPENSSLaddallalgorithms = procedure; cdecl; + TCRYPTOcleanupAllExData = procedure; cdecl; + TRandScreen = procedure; cdecl; + TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; + TBioFreeAll = procedure(b: PBIO); cdecl; + TBioSMem = function: PBIO_METHOD; cdecl; + TBioCtrlPending = function(b: PBIO): integer; cdecl; + TBioRead = function(b: PBIO; Buf: PByte; Len: integer): integer; cdecl; + TBioWrite = function(b: PBIO; Buf: PByte; Len: integer): integer; cdecl; + Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; + TPKCS12parse = function(p12: SslPtr; pass: PByte; var pkey, cert, ca: SslPtr): integer; cdecl; + TPKCS12free = procedure(p12: SslPtr); cdecl; + TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl; + TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; + TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; + TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; + TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf} + Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; + Td2iX509bio = function(b:PBIO; x:PX509): PX509; cdecl; {pf} + TPEMReadBioX509 = function(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; {pf} + TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf} + Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl; + + // 3DES functions + TDESsetoddparity = procedure(Key: des_cblock); cdecl; + TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl; + TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl; + //thread lock functions + TCRYPTOnumlocks = function: integer; cdecl; + TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl; + +var +// libssl.dll + _SslGetError: TSslGetError = nil; + _SslLibraryInit: TSslLibraryInit = nil; + _SslLoadErrorStrings: TSslLoadErrorStrings = nil; + _SslCtxSetCipherList: TSslCtxSetCipherList = nil; + _SslCtxNew: TSslCtxNew = nil; + _SslCtxFree: TSslCtxFree = nil; + _SslSetFd: TSslSetFd = nil; + _SslMethodV2: TSslMethodV2 = nil; + _SslMethodV3: TSslMethodV3 = nil; + _SslMethodTLSV1: TSslMethodTLSV1 = nil; + _SslMethodTLSV11: TSslMethodTLSV11 = nil; + _SslMethodTLSV12: TSslMethodTLSV12 = nil; + _SslMethodV23: TSslMethodV23 = nil; + _SslMethodTLS: TSslMethodTLS = nil; + _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil; + _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil; + _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; + _SslCtxUseCertificate: TSslCtxUseCertificate = nil; + _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil; + _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil; + _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; + _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; + _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; + _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil; + _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil; + _SslCtxCtrl: TSslCtxCtrl = nil; + _SslNew: TSslNew = nil; + _SslFree: TSslFree = nil; + _SslAccept: TSslAccept = nil; + _SslConnect: TSslConnect = nil; + _SslShutdown: TSslShutdown = nil; + _SslRead: TSslRead = nil; + _SslPeek: TSslPeek = nil; + _SslWrite: TSslWrite = nil; + _SslPending: TSslPending = nil; + _SslGetVersion: TSslGetVersion = nil; + _SslGetPeerCertificate: TSslGetPeerCertificate = nil; + _SslCtxSetVerify: TSslCtxSetVerify = nil; + _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil; + _SSLCipherGetName: TSSLCipherGetName = nil; + _SSLCipherGetBits: TSSLCipherGetBits = nil; + _SSLGetVerifyResult: TSSLGetVerifyResult = nil; + _SSLCtrl: TSSLCtrl = nil; + +// libeay.dll + _X509New: TX509New = nil; + _X509NameOneline: TX509NameOneline = nil; + _X509GetSubjectName: TX509GetSubjectName = nil; + _X509GetIssuerName: TX509GetIssuerName = nil; + _X509NameHash: TX509NameHash = nil; + _X509Digest: TX509Digest = nil; + _X509print: TX509print = nil; + _X509SetVersion: TX509SetVersion = nil; + _X509SetPubkey: TX509SetPubkey = nil; + _X509SetIssuerName: TX509SetIssuerName = nil; + _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil; + _X509Sign: TX509Sign = nil; + _X509GmtimeAdj: TX509GmtimeAdj = nil; + _X509SetNotBefore: TX509SetNotBefore = nil; + _X509SetNotAfter: TX509SetNotAfter = nil; + _X509GetSerialNumber: TX509GetSerialNumber = nil; + _EvpPkeyNew: TEvpPkeyNew = nil; + _EvpPkeyFree: TEvpPkeyFree = nil; + _EvpPkeyAssign: TEvpPkeyAssign = nil; + _EvpGetDigestByName: TEvpGetDigestByName = nil; + _EVPcleanup: TEVPcleanup = nil; + _SSLeayversion: TSSLeayversion = nil; + _OpenSSLversion: TOpenSSLversion = nil; + _ErrErrorString: TErrErrorString = nil; + _ErrGetError: TErrGetError = nil; + _ErrClearError: TErrClearError = nil; + _ErrFreeStrings: TErrFreeStrings = nil; + _ErrRemoveState: TErrRemoveState = nil; + _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; + _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; + _RandScreen: TRandScreen = nil; + _BioNew: TBioNew = nil; + _BioFreeAll: TBioFreeAll = nil; + _BioSMem: TBioSMem = nil; + _BioCtrlPending: TBioCtrlPending = nil; + _BioRead: TBioRead = nil; + _BioWrite: TBioWrite = nil; + _d2iPKCS12bio: Td2iPKCS12bio = nil; + _PKCS12parse: TPKCS12parse = nil; + _PKCS12free: TPKCS12free = nil; + _RsaGenerateKey: TRsaGenerateKey = nil; + _Asn1UtctimeNew: TAsn1UtctimeNew = nil; + _Asn1UtctimeFree: TAsn1UtctimeFree = nil; + _Asn1IntegerSet: TAsn1IntegerSet = nil; + _Asn1IntegerGet: TAsn1IntegerGet = nil; {pf} + _i2dX509bio: Ti2dX509bio = nil; + _d2iX509bio: Td2iX509bio = nil; {pf} + _PEMReadBioX509: TPEMReadBioX509 = nil; {pf} + _SkX509PopFree: TSkX509PopFree = nil; {pf} + _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; + + // 3DES functions + _DESsetoddparity: TDESsetoddparity = nil; + _DESsetkeychecked: TDESsetkeychecked = nil; + _DESecbencrypt: TDESecbencrypt = nil; + //thread lock functions + _CRYPTOnumlocks: TCRYPTOnumlocks = nil; + _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil; +{$ELSE STATIC} +// libssl.dll + function _SslGetError(s: PSSL; ret_code: Integer):Integer; cdecl; external DLLSSLName name 'SSL_get_error'; + function _SslLibraryInit(): integer; cdecl; external DLLSSLName name 'SSL_library_init'; + procedure _SslLoadErrorStrings(); cdecl;external DLLSSLName name 'SSL_load_error_strings'; + function _SslCtxSetCipherList (arg0: PSSL_CTX; str: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_set_cipher_list'; + function _SslCtxNew (meth: PSSL_METHOD):PSSL_CTX; cdecl;external DLLSSLName name 'SSL_CTX_new'; + procedure _SslCtxFree(arg0: PSSL_CTX); cdecl;external DLLSSLName name 'SSL_CTX_free'; + function _SslSetFd (s: PSSL; fd: Integer):Integer; cdecl;external DLLSSLName name 'SSL_set_fd'; + function _SslMethodV2():PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv2_method'; + function _SslMethodV3():PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv3_method'; + function _SslMethodTLSV1:PSSL_METHOD; cdecl;external DLLSSLName name 'TLSv1_method'; + function _SslMethodV23:PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv23_method'; + function _SslCtxUsePrivateKey (ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_PrivateKey'; + function _SslCtxUsePrivateKeyASN1 (pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_PrivateKey_ASN1'; + function _SslCtxUsePrivateKeyFile (ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_RSAPrivateKey_file'; + function _SslCtxUseCertificate (ctx: PSSL_CTX; x: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate'; + function _SslCtxUseCertificateASN1 (ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_ASN1'; + function _SslCtxUseCertificateFile (ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_file'; + function _SslCtxUseCertificateChainFile (ctx: PSSL_CTX; const _file: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_chain_file'; + function _SslCtxCheckPrivateKeyFile (ctx: PSSL_CTX):Integer; cdecl;external DLLSSLName name 'SSL_CTX_check_private_key'; + procedure _SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_default_passwd_cb'; + procedure _SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_default_passwd_cb_userdata'; + function _SslCtxLoadVerifyLocations (ctx: PSSL_CTX; const CAfile: PByte; const CApath: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_load_verify_locations'; + function _SslCtxCtrl (ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl;external DLLSSLName name 'SSL_CTX_ctrl'; + function _SslNew (ctx: PSSL_CTX):PSSL; cdecl;external DLLSSLName name 'SSL_new'; + procedure _SslFree(ssl: PSSL); cdecl;external DLLSSLName name 'SSL_free'; + function _SslAccept (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_accept'; + function _SslConnect (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_connect'; + function _SslShutdown (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_shutdown'; + function _SslRead (ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_read'; + function _SslPeek (ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_peek'; + function _SslWrite (ssl: PSSL; const buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_write'; + function _SslPending (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_pending'; + function _SslGetVersion (ssl: PSSL):PByte; cdecl;external DLLSSLName name 'SSL_get_version'; + function _SslGetPeerCertificate (ssl: PSSL):PX509; cdecl;external DLLSSLName name 'SSL_get_peer_certificate'; + procedure _SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_verify'; + function _SslGetCurrentCipher (s: PSSL):SslPtr; cdecl;external DLLSSLName name 'SSL_get_current_cipher'; + function _SslCipherGetName (c: Sslptr):PByte; cdecl;external DLLSSLName name 'SSL_CIPHER_get_name'; + function _SslCipherGetBits (c: SslPtr; alg_bits: PInteger):Integer; cdecl;external DLLSSLName name 'SSL_CIPHER_get_bits'; + function _SslGetVerifyResult (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_get_verify_result'; + function _SslCtrl (ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_ctrl'; + +// libeay.dll + function _X509New: PX509; cdecl;external DLLUtilName name 'X509_new'; + function _X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer):PByte; cdecl;external DLLUtilName name 'X509_NAME_oneline'; + function _X509GetSubjectName(a: PX509):PX509_NAME; cdecl;external DLLUtilName name 'X509_get_subject_name'; + function _X509GetIssuerName(a: PX509):PX509_NAME; cdecl;external DLLUtilName name 'X509_get_issuer_name'; + function _X509NameHash(x: PX509_NAME):Cardinal; cdecl;external DLLUtilName name 'X509_NAME_hash'; + function _X509Digest(data: PX509; _type: PEVP_MD; md: PByte; len: PInteger):Integer; cdecl;external DLLUtilName name 'X509_digest'; + function _X509print(b: PBIO; a: PX509): integer; cdecl;external DLLUtilName name 'X509_print'; + function _X509SetVersion(x: PX509; version: integer): integer; cdecl;external DLLUtilName name 'X509_set_version'; + function _X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; cdecl;external DLLUtilName name 'X509_set_pubkey'; + function _X509SetIssuerName(x: PX509; name: PX509_NAME): integer; cdecl;external DLLUtilName name 'X509_set_issuer_name'; + function _X509NameAddEntryByTxt(name: PX509_NAME; field: PByte; _type: integer; + bytes: PByte; len, loc, _set: integer): integer; cdecl;external DLLUtilName name 'X509_NAME_add_entry_by_txt'; + function _X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl;external DLLUtilName name 'X509_sign'; + function _X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl;external DLLUtilName name 'X509_gmtime_adj'; + function _X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;external DLLUtilName name 'X509_set_notBefore'; + function _X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;external DLLUtilName name 'X509_set_notAfter'; + function _X509GetSerialNumber(x: PX509): PASN1_INTEGER; cdecl;external DLLUtilName name 'X509_get_serialNumber'; + function _EvpPkeyNew: EVP_PKEY; cdecl;external DLLUtilName name 'EVP_PKEY_new'; + procedure _EvpPkeyFree(pk: EVP_PKEY); cdecl;external DLLUtilName name 'EVP_PKEY_free'; + function _EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl;external DLLUtilName name 'EVP_PKEY_assign'; + function _EvpGetDigestByName(Name: PByte): PEVP_MD; cdecl;external DLLUtilName name 'EVP_get_digestbyname'; + procedure _EVPcleanup; cdecl;external DLLUtilName name 'EVP_cleanup'; + function _SSLeayversion(t: integer): PByte; cdecl;external DLLUtilName name 'SSLeay_version'; + procedure _ErrErrorString(e: integer; buf: PByte; len: integer); cdecl;external DLLUtilName name 'ERR_error_string_n'; + function _ErrGetError: integer; cdecl;external DLLUtilName name 'ERR_get_error'; + procedure _ErrClearError; cdecl;external DLLUtilName name 'ERR_clear_error'; + procedure _ErrFreeStrings; cdecl;external DLLUtilName name 'ERR_free_strings'; + procedure _ErrRemoveState(pid: integer); cdecl;external DLLUtilName name 'ERR_remove_state'; + procedure _OPENSSLaddallalgorithms; cdecl;external DLLUtilName name 'OPENSSL_add_all_algorithms_noconf'; + procedure _CRYPTOcleanupAllExData; cdecl;external DLLUtilName name 'CRYPTO_cleanup_all_ex_data'; + procedure _RandScreen; cdecl;external DLLUtilName name 'RAND_screen'; + function _BioNew(b: PBIO_METHOD): PBIO; cdecl;external DLLUtilName name 'BIO_new'; + procedure _BioFreeAll(b: PBIO); cdecl;external DLLUtilName name 'BIO_free_all'; + function _BioSMem: PBIO_METHOD; cdecl;external DLLUtilName name 'BIO_s_mem'; + function _BioCtrlPending(b: PBIO): integer; cdecl;external DLLUtilName name 'BIO_ctrl_pending'; + function _BioRead(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;external DLLUtilName name 'BIO_read'; + function _BioWrite(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;external DLLUtilName name 'BIO_write'; + function _d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl;external DLLUtilName name 'd2i_PKCS12_bio'; + function _PKCS12parse(p12: SslPtr; pass: PByte; var pkey, cert, ca: SslPtr): integer; cdecl;external DLLUtilName name 'PKCS12_parse'; + procedure _PKCS12free(p12: SslPtr); cdecl;external DLLUtilName name 'PKCS12_free'; + function _RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl;external DLLUtilName name 'RSA_generate_key'; + function _Asn1UtctimeNew: PASN1_UTCTIME; cdecl;external DLLUtilName name 'ASN1_UTCTIME_new'; + procedure _Asn1UtctimeFree(a: PASN1_UTCTIME); cdecl;external DLLUtilName name 'ASN1_UTCTIME_free'; + function _Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; cdecl;external DLLUtilName name 'ASN1_INTEGER_set'; + function _Asn1IntegerGet(a: PASN1_INTEGER): integer; cdecl;external DLLUtilName name 'ASN1_INTEGER_get'; + function _i2dX509bio(b: PBIO; x: PX509): integer; cdecl;external DLLUtilName name 'i2d_X509_bio'; + function _d2iX509bio(b:PBIO; x:PX509): PX509; cdecl; external DLLUtilName name 'd2i_X509_bio'; + function _PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; external DLLUtilName name 'PEM_read_bio_X509'; +{$IFNDEF MSWINDOWS} + procedure _SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); cdecl; external DLLUtilName name 'sk_X509_pop_free'; +{$ENDIF} + function _i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; cdecl;external DLLUtilName name 'i2d_PrivateKey_bio'; + + + // 3DES functions + procedure _DESsetoddparity(Key: des_cblock); cdecl;external DLLUtilName name 'DES_set_odd_parity'; + function _DESsetkeychecked (key: des_cblock; schedule: des_key_schedule): Integer; cdecl;external DLLUtilName name 'DES_set_key_checked'; + procedure _DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl;external DLLUtilName name 'DES_ecb_encrypt'; + //thread lock functions + function _CRYPTOnumlocks: integer; cdecl;external DLLUtilName name 'CRYPTO_num_locks'; + procedure _CRYPTOSetLockingCallback(cb: Sslptr); cdecl; external DLLUtilName name 'CRYPTO_set_locking_callback'; +{$ENDIF} +{$ENDIF} + + +var + SSLCS: TCriticalSection; + SSLloaded: boolean = false; +{$IFNDEF CIL} + Locks: Array of TCriticalSection; +{$ENDIF} + +{$IFNDEF CIL} +// libssl.dll +function SslGetError(s: PSSL; ret_code: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetError){$ENDIF} then + Result := _SslGetError(s, ret_code) + else + Result := SSL_ERROR_SSL; +end; + +function SslLibraryInit:Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslLibraryInit){$ENDIF} then + Result := _SslLibraryInit + else + Result := 1; +end; + +procedure SslLoadErrorStrings; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslLoadErrorStrings){$ENDIF} then + _SslLoadErrorStrings; +end; + +function SslCtxSetCipherList(arg0: PSSL_CTX; str: PByte):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetCipherList){$ENDIF} then + Result := _SslCtxSetCipherList(arg0, str) + else + Result := 0; +end; + +function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxNew){$ENDIF} then + Result := _SslCtxNew(meth) + else + Result := nil; +end; + +procedure SslCtxFree(arg0: PSSL_CTX); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxFree){$ENDIF} then + _SslCtxFree(arg0); +end; + +function SslSetFd(s: PSSL; fd: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslSetFd){$ENDIF} then + Result := _SslSetFd(s, fd) + else + Result := 0; +end; + +function SslMethodV2:PSSL_METHOD; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV2){$ENDIF} then + Result := _SslMethodV2 + else + Result := nil; +end; + +function SslMethodV3:PSSL_METHOD; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV3){$ENDIF} then + Result := _SslMethodV3 + else + Result := nil; +end; + +function SslMethodTLSV1:PSSL_METHOD; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodTLSV1){$ENDIF} then + Result := _SslMethodTLSV1 + else + Result := nil; +end; + +function SslMethodTLSV11:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLSV11) then + Result := _SslMethodTLSV11 + else + Result := nil; +end; + +function SslMethodTLSV12:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLSV12) then + Result := _SslMethodTLSV12 + else + Result := nil; +end; + +function SslMethodV23:PSSL_METHOD; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV23){$ENDIF} then + Result := _SslMethodV23 + else + Result := nil; +end; + +function SslMethodTLS:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLS) then + Result := _SslMethodTLS + else + Result := nil; +end; + +function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKey){$ENDIF} then + Result := _SslCtxUsePrivateKey(ctx, pkey) + else + Result := 0; +end; + +function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: TSynaBytes; len: integer):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKeyASN1){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(d).Data; + {$ELSE} + buf := PByte(d); + {$ENDIF} + Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(buf), len) + end + else + Result := 0; +end; + +//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; +function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKeyFile){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(_file).Data; + {$ELSE} + buf := Pointer(_file); + {$ENDIF} + Result := _SslCtxUsePrivateKeyFile(ctx, buf, _type) + end + else + Result := 0; +end; + +function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificate){$ENDIF} then + Result := _SslCtxUseCertificate(ctx, x) + else + Result := 0; +end; + +function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: TSynaBytes):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateASN1){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(d).Data; + {$ELSE} + buf := PByte(d); + {$ENDIF} + Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(buf)) + end + else + Result := 0; +end; + +function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateFile){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(_file).Data; + {$ELSE} + buf := PByte(_file); + {$ENDIF} + Result := _SslCtxUseCertificateFile(ctx, buf, _type) + end + else + Result := 0; +end; + +//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: TSynaBytes):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateChainFile){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(_file).Data; + {$ELSE} + buf := Pointer(_file); + {$ENDIF} + Result := _SslCtxUseCertificateChainFile(ctx, buf) + end + else + Result := 0; +end; + +function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxCheckPrivateKeyFile){$ENDIF} then + Result := _SslCtxCheckPrivateKeyFile(ctx) + else + Result := 0; +end; + +procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetDefaultPasswdCb){$ENDIF} then + _SslCtxSetDefaultPasswdCb(ctx, cb); +end; + +procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetDefaultPasswdCbUserdata){$ENDIF} then + _SslCtxSetDefaultPasswdCbUserdata(ctx, u); +end; + +//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; +function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: TSynaBytes; const CApath: TSynaBytes):Integer; +var buf,path: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxLoadVerifyLocations){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(CAfile).Data; + path := TSynaBytes(CApath).Data; + {$ELSE} + buf := PByte(CAfile); + path := PByte(CApath); + {$ENDIF} + Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(buf), SslPtr(path)) + end + else + Result := 0; +end; + +function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxCtrl){$ENDIF} then + Result := _SslCtxCtrl(ctx, cmd, larg, parg) + else + Result := 0; +end; + +function SslNew(ctx: PSSL_CTX):PSSL; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslNew){$ENDIF} then + Result := _SslNew(ctx) + else + Result := nil; +end; + +procedure SslFree(ssl: PSSL); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslFree){$ENDIF} then + _SslFree(ssl); +end; + +function SslAccept(ssl: PSSL):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslAccept) {$ENDIF}then + Result := _SslAccept(ssl) + else + Result := -1; +end; + +function SslConnect(ssl: PSSL):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslConnect) {$ENDIF}then + Result := _SslConnect(ssl) + else + Result := -1; +end; + +function SslShutdown(ssl: PSSL):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslShutdown){$ENDIF} then + Result := _SslShutdown(ssl) + else + Result := -1; +end; + +//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslRead) {$ENDIF}then + Result := _SslRead(ssl, PByte(buf), num) + else + Result := -1; +end; + +//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslPeek){$ENDIF} then + Result := _SslPeek(ssl, PByte(buf), num) + else + Result := -1; +end; + +//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; +function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslWrite){$ENDIF} then + Result := _SslWrite(ssl, PByte(buf), num) + else + Result := -1; +end; + +function SslPending(ssl: PSSL):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslPending){$ENDIF} then + Result := _SslPending(ssl) + else + Result := 0; +end; + +//function SslGetVersion(ssl: PSSL):PChar; +function SslGetVersion(ssl: PSSL):string; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetVersion){$ENDIF} then + Result := synabyte.StringOf(_SslGetVersion(ssl)) + else + Result := ''; +end; + +function SslGetPeerCertificate(ssl: PSSL):PX509; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetPeerCertificate){$ENDIF} then + Result := _SslGetPeerCertificate(ssl) + else + Result := nil; +end; + +//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); +procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetVerify){$ENDIF} then + _SslCtxSetVerify(ctx, mode, @arg2); +end; + +function SSLGetCurrentCipher(s: PSSL):SslPtr; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLGetCurrentCipher){$ENDIF} then +{$IFDEF CIL} +{$ELSE} + Result := _SSLGetCurrentCipher(s) +{$ENDIF} + else + Result := nil; +end; + +//function SSLCipherGetName(c: SslPtr):PChar; +function SSLCipherGetName(c: SslPtr):string; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCipherGetName){$ENDIF} then + Result := synabyte.StringOf(_SSLCipherGetName(c)) + else + Result := ''; +end; + +//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer; +function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCipherGetBits){$ENDIF} then + Result := _SSLCipherGetBits(c, @alg_bits) + else + Result := 0; +end; + +function SSLGetVerifyResult(ssl: PSSL):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLGetVerifyResult){$ENDIF} then + Result := _SSLGetVerifyResult(ssl) + else + Result := X509_V_ERR_APPLICATION_VERIFICATION; +end; + + +function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCtrl){$ENDIF} then + Result := _SSLCtrl(ssl, cmd, larg, parg) + else + Result := X509_V_ERR_APPLICATION_VERIFICATION; +end; + +// libeay.dll +function X509New: PX509; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509New){$ENDIF} then + Result := _X509New + else + Result := nil; +end; + +procedure X509Free(x: PX509); +begin + if InitSSLInterface and Assigned(_X509Free) then + _X509Free(x); +end; + +function X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer): string; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameOneline){$ENDIF} then + Result := synabyte.StringOf(_X509NameOneline(a, buf,size)) + else + Result := ''; +end; + +function X509GetSubjectName(a: PX509):PX509_NAME; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetSubjectName){$ENDIF} then + Result := _X509GetSubjectName(a) + else + Result := nil; +end; + +function X509GetIssuerName(a: PX509):PX509_NAME; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetIssuerName){$ENDIF} then + Result := _X509GetIssuerName(a) + else + Result := nil; +end; + +function X509NameHash(x: PX509_NAME):Cardinal; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameHash){$ENDIF} then + Result := _X509NameHash(x) + else + Result := 0; +end; + +//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +function X509Digest(data: PX509; _type: PEVP_MD; md: TSynaBytes; var len: Integer):Integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509Digest){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(md).Data; + {$ELSE} + buf := PByte(md); + {$ENDIF} + Result := _X509Digest(data, _type, buf, @len) + end + else + Result := 0; +end; + +function EvpPkeyNew: EVP_PKEY; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyNew){$ENDIF} then + Result := _EvpPkeyNew + else + Result := nil; +end; + +procedure EvpPkeyFree(pk: EVP_PKEY); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyFree){$ENDIF} then + _EvpPkeyFree(pk); +end; + +function SSLeayversion(t: integer): string; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLeayversion){$ENDIF} then + Result := synabyte.StringOf(_SSLeayversion(t)) + else + Result := ''; +end; + +function OpenSSLversion(t: integer): string; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_OpenSSLversion){$ENDIF} then + Result := synabyte.StringOf(_OpenSSLversion(t)) + else + Result := ''; +end; + +procedure ErrErrorString(e: integer; var buf: TSynaBytes; len: integer); +var ptr: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrErrorString){$ENDIF} then + begin + {$IFDEF UNICODE} + ptr := TSynaBytes(buf).Data; + {$ELSE} + ptr := PByte(buf); + {$ENDIF} + _ErrErrorString(e, ptr, len); + end; +end; + +function ErrGetError: integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrGetError){$ENDIF} then + Result := _ErrGetError + else + Result := SSL_ERROR_SSL; +end; + +procedure ErrClearError; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrClearError){$ENDIF} then + _ErrClearError; +end; + +procedure ErrFreeStrings; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrFreeStrings){$ENDIF} then + _ErrFreeStrings; +end; + +procedure ErrRemoveState(pid: integer); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrRemoveState){$ENDIF} then + _ErrRemoveState(pid); +end; + +procedure OPENSSLaddallalgorithms; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_OPENSSLaddallalgorithms){$ENDIF} then + _OPENSSLaddallalgorithms; +end; + +procedure EVPcleanup; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EVPcleanup){$ENDIF} then + _EVPcleanup; +end; + +procedure CRYPTOcleanupAllExData; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_CRYPTOcleanupAllExData){$ENDIF} then + _CRYPTOcleanupAllExData; +end; + +procedure RandScreen; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_RandScreen){$ENDIF} then + _RandScreen; +end; + +function BioNew(b: PBIO_METHOD): PBIO; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioNew){$ENDIF} then + Result := _BioNew(b) + else + Result := nil; +end; + +procedure BioFreeAll(b: PBIO); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioFreeAll){$ENDIF} then + _BioFreeAll(b); +end; + +function BioSMem: PBIO_METHOD; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioSMem){$ENDIF} then + Result := _BioSMem + else + Result := nil; +end; + +function BioCtrlPending(b: PBIO): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioCtrlPending){$ENDIF} then + Result := _BioCtrlPending(b) + else + Result := 0; +end; + +//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; +function BioRead(b: PBIO; Buf: PByte; Len: integer): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioRead){$ENDIF} then + Result := _BioRead(b, buf, Len) + else + Result := -2; +end; + +//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; +function BioWrite(b: PBIO; Buf: PByte; Len: integer): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioWrite){$ENDIF} then + Result := _BioWrite(b, Buf, Len) + else + Result := -2; +end; + +function X509print(b: PBIO; a: PX509): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509print){$ENDIF} then + Result := _X509print(b, a) + else + Result := 0; +end; + +function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iPKCS12bio){$ENDIF} then + Result := _d2iPKCS12bio(b, Pkcs12) + else + Result := nil; +end; + +function PKCS12parse(p12: SslPtr; pass: TSynaBytes; var pkey, cert, ca: SslPtr): integer; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PKCS12parse){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(pass).Data; + {$ELSE} + buf := Pointer(pass); + {$ENDIF} + Result := _PKCS12parse(p12, SslPtr(buf), pkey, cert, ca) + end + else + Result := 0; +end; + +procedure PKCS12free(p12: SslPtr); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PKCS12free){$ENDIF} then + _PKCS12free(p12); +end; + +function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_RsaGenerateKey){$ENDIF} then + Result := _RsaGenerateKey(bits, e, callback, cb_arg) + else + Result := nil; +end; + +function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyAssign){$ENDIF} then + Result := _EvpPkeyAssign(pkey, _type, key) + else + Result := 0; +end; + +function X509SetVersion(x: PX509; version: integer): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetVersion){$ENDIF} then + Result := _X509SetVersion(x, version) + else + Result := 0; +end; + +function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetPubkey){$ENDIF} then + Result := _X509SetPubkey(x, pkey) + else + Result := 0; +end; + +function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetIssuerName){$ENDIF} then + Result := _X509SetIssuerName(x, name) + else + Result := 0; +end; + +function X509NameAddEntryByTxt(name: PX509_NAME; field: TSynaBytes; _type: integer; + bytes: TSynaBytes; len, loc, _set: integer): integer; +var buf: PByte; + strb: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameAddEntryByTxt){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(field).Data; + strb := TSynaBytes(bytes).Data; + {$ELSE} + buf := Pointer(field); + strb := Pointer(bytes); + {$ENDIF} + Result := _X509NameAddEntryByTxt(name, buf, _type, strb, len, loc, _set) + end + else + Result := 0; +end; + +function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509Sign){$ENDIF} then + Result := _X509Sign(x, pkey, md) + else + Result := 0; +end; + +function Asn1UtctimeNew: PASN1_UTCTIME; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1UtctimeNew){$ENDIF} then + Result := _Asn1UtctimeNew + else + Result := nil; +end; + +procedure Asn1UtctimeFree(a: PASN1_UTCTIME); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1UtctimeFree){$ENDIF} then + _Asn1UtctimeFree(a); +end; + +function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GmtimeAdj){$ENDIF} then + Result := _X509GmtimeAdj(s, adj) + else + Result := nil; +end; + +function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetNotBefore){$ENDIF} then + Result := _X509SetNotBefore(x, tm) + else + Result := 0; +end; + +function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetNotAfter){$ENDIF} then + Result := _X509SetNotAfter(x, tm) + else + Result := 0; +end; + +function i2dX509bio(b: PBIO; x: PX509): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_i2dX509bio){$ENDIF} then + Result := _i2dX509bio(b, x) + else + Result := 0; +end; + +function d2iX509bio(b: PBIO; x: PX509): PX509; {pf} +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iX509bio){$ENDIF} then + Result := _d2iX509bio(x,b) + else + Result := nil; +end; + +function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PEMReadBioX509){$ENDIF} then + Result := _PEMReadBioX509(b,x,callback,cb_arg) + else + Result := nil; +end; + +procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf} +begin +{$IFNDEF MSWINDOWS} + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SkX509PopFree){$ENDIF} then + _SkX509PopFree(st,func); +{$ENDIF} +end; + +function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_i2dPrivateKeyBio){$ENDIF} then + Result := _i2dPrivateKeyBio(b, pkey) + else + Result := 0; +end; + +function EvpGetDigestByName(Name: TSynaBytes): PEVP_MD; +var buf: PByte; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpGetDigestByName){$ENDIF} then + begin + {$IFDEF UNICODE} + buf := TSynaBytes(name).Data; + {$ELSE} + buf := PByte(name); + {$ENDIF} + Result := _EvpGetDigestByName(buf) + end + else + Result := nil; +end; + +function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1IntegerSet){$ENDIF} then + Result := _Asn1IntegerSet(a, v) + else + Result := 0; +end; + +function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1IntegerGet){$ENDIF} then + Result := _Asn1IntegerGet(a) + else + Result := 0; +end; + +function X509GetSerialNumber(x: PX509): PASN1_INTEGER; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetSerialNumber){$ENDIF} then + Result := _X509GetSerialNumber(x) + else + Result := nil; +end; + +// 3DES functions +procedure DESsetoddparity(Key: des_cblock); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESsetoddparity){$ENDIF} then + _DESsetoddparity(Key); +end; + +function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESsetkeychecked){$ENDIF} then + Result := _DESsetkeychecked(key, schedule) + else + Result := -1; +end; + +procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); +begin + if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESecbencrypt){$ENDIF} then + _DESecbencrypt(Input, output, ks, enc); +end; + +procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; +begin + if ltype>High(Locks) then exit; //Should never happen? + + if (mode and 1) > 0 then + TCriticalSection(Locks[ltype]).Enter + else + TCriticalSection(Locks[ltype]).Leave; +end; + +procedure InitLocks; +var + n: integer; +begin + Setlength(Locks, _CRYPTOnumlocks); + for n := 0 to high(Locks) do + Locks[n] := TCriticalSection.Create; + _CRYPTOsetlockingcallback(@locking_callback); +end; + +procedure FreeLocks; +var + n: integer; +begin + _CRYPTOsetlockingcallback(nil); + for n := 0 to high(Locks) do + Locks[n].Free; + Setlength(Locks, 0); +end; + +{$ENDIF} + +{$IFNDEF STATIC} +function LoadLib(const Value: string): HModule; +begin +{$IFDEF CIL} + Result := LoadLibrary(Value); +{$ELSE} + Result := LoadLibrary(PChar(Value)); +{$ENDIF} +end; + +function GetProcAddr(module: HModule; const ProcName: string): SslPtr; +begin +{$IFDEF CIL} + Result := GetProcAddress(module, ProcName); +{$ELSE} + Result := GetProcAddress(module, PChar(ProcName)); +{$ENDIF} +end; +{$ENDIF} + +function InitSSLInterface: Boolean; +var + s: string; + x: integer; +begin + {pf} + if SSLLoaded then + begin + Result := TRUE; + exit; + end; + {/pf} + Result := False; + if SSLCS = nil then + Exit; + SSLCS.Enter; + try + if not IsSSLloaded then + begin +{$IFDEF CIL} + SSLLibHandle := 1; + SSLUtilHandle := 1; +{$ELSE} + + {$IFDEF MSWINDOWS} + SSLUtilHandle := LoadLib(DLL_LIBCRYPTO_1_1); + SSLLibHandle := LoadLib(DLL_LIBSSL_1_1); + + if (SSLUtilHandle = 0) or (SSLLibHandle = 0) then + begin + FreeLibrary(SSLLibHandle); + FreeLibrary(SSLUtilHandle); + + SSLUtilHandle := LoadLib(DLLUtilName); + SSLLibHandle := LoadLib(DLLSSLName); + if (SSLLibHandle = 0) then + SSLLibHandle := LoadLib(DLLSSLName2); + end; + {$ELSE} + SSLUtilHandle := LoadLib(DLLUtilName); + SSLLibHandle := LoadLib(DLLSSLName); + {$ENDIF} +{$ENDIF} + if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then + begin +{$IFNDEF CIL} + {$IFNDEF STATIC} + _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); + _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init'); + _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings'); + _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list'); + _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new'); + _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free'); + _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd'); + _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method'); + _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method'); + _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method'); + _SslMethodTLSV11 := GetProcAddr(SSLLibHandle, 'TLSv1_1_method'); + _SslMethodTLSV12 := GetProcAddr(SSLLibHandle, 'TLSv1_2_method'); + _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method'); + _SslMethodTLS := GetProcAddr(SSLLibHandle, 'TLS_method'); + _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey'); + _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1'); + //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file, + //because SSL_CTX_use_PrivateKey_file not support DER format. :-O + _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file'); + _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate'); + _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1'); + _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file'); + _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file'); + _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key'); + _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb'); + _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata'); + _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations'); + _SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl'); + _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new'); + _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free'); + _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept'); + _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect'); + _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown'); + _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read'); + _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek'); + _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write'); + _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending'); + _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate'); + _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version'); + _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify'); + _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher'); + _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name'); + _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits'); + _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result'); + _SslCtrl := GetProcAddr(SSLLibHandle, 'SSL_ctrl'); + + _X509New := GetProcAddr(SSLUtilHandle, 'X509_new'); + _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); + _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); + _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); + _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); + _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); + _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); + _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); + _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version'); + _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey'); + _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name'); + _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt'); + _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign'); + _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj'); + _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore'); + _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter'); + _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber'); + _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new'); + _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free'); + _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); + _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); + _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); + _OpenSSLversion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); + _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); + _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); + _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); + _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); + _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf'); + _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data'); + _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen'); + _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new'); + _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all'); + _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem'); + _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending'); + _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read'); + _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write'); + _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); + _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); + _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); + _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key'); + _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); + _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); + _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); + _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf} + _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); + _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf} + _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf} + _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf} + _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); + + // 3DES functions + _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); + _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); + _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); + // + _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks'); + _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback'); + {$ENDIF STATIC} +{$ENDIF} +{$IFDEF CIL} + SslLibraryInit; + SslLoadErrorStrings; + OPENSSLaddallalgorithms; + RandScreen; +{$ELSE} + SetLength(s, 1024); + x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLLibFile := s; + SetLength(s, 1024); + x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); + SetLength(s, x); + SSLUtilFile := s; + //init library + {$IFNDEF STATIC}if assigned(_SslLibraryInit) then{$ENDIF} + _SslLibraryInit; + {$IFNDEF STATIC}if assigned(_SslLoadErrorStrings) then{$ENDIF} + _SslLoadErrorStrings; + {$IFNDEF STATIC}if assigned(_OPENSSLaddallalgorithms) then{$ENDIF} + _OPENSSLaddallalgorithms; + {$IFNDEF STATIC}if assigned(_RandScreen) then{$ENDIF} + _RandScreen; + {$IFNDEF STATIC} + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + {$ENDIF} + InitLocks; +{$ENDIF} + SSLloaded := True; +{$IFDEF OS2} + Result := InitEMXHandles; +{$ELSE OS2} + Result := True; +{$ENDIF OS2} + end + else + begin + //load failed! + if SSLLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLLibHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLUtilHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + SSLCS.Leave; + end; +end; + +function DestroySSLInterface: Boolean; +begin + SSLCS.Enter; + try + if IsSSLLoaded then + begin + //deinit library +{$IFNDEF CIL} + {$IFNDEF STATIC} + if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then + {$ENDIF} + FreeLocks; +{$ENDIF} + EVPCleanup; + CRYPTOcleanupAllExData; + ErrRemoveState(0); + end; + SSLloaded := false; + if SSLLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLLibHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(SSLUtilHandle); +{$ENDIF} + SSLLibHandle := 0; + end; + +{$IFNDEF CIL} +{$IFNDEF STATIC} + _SslGetError := nil; + _SslLibraryInit := nil; + _SslLoadErrorStrings := nil; + _SslCtxSetCipherList := nil; + _SslCtxNew := nil; + _SslCtxFree := nil; + _SslSetFd := nil; + _SslMethodV2 := nil; + _SslMethodV3 := nil; + _SslMethodTLSV1 := nil; + _SslMethodTLSV11 := nil; + _SslMethodTLSV12 := nil; + _SslMethodV23 := nil; + _SslMethodTLS := nil; + _SslCtxUsePrivateKey := nil; + _SslCtxUsePrivateKeyASN1 := nil; + _SslCtxUsePrivateKeyFile := nil; + _SslCtxUseCertificate := nil; + _SslCtxUseCertificateASN1 := nil; + _SslCtxUseCertificateFile := nil; + _SslCtxUseCertificateChainFile := nil; + _SslCtxCheckPrivateKeyFile := nil; + _SslCtxSetDefaultPasswdCb := nil; + _SslCtxSetDefaultPasswdCbUserdata := nil; + _SslCtxLoadVerifyLocations := nil; + _SslCtxCtrl := nil; + _SslNew := nil; + _SslFree := nil; + _SslAccept := nil; + _SslConnect := nil; + _SslShutdown := nil; + _SslRead := nil; + _SslPeek := nil; + _SslWrite := nil; + _SslPending := nil; + _SslGetPeerCertificate := nil; + _SslGetVersion := nil; + _SslCtxSetVerify := nil; + _SslGetCurrentCipher := nil; + _SslCipherGetName := nil; + _SslCipherGetBits := nil; + _SslGetVerifyResult := nil; + _SslCtrl := nil; + + _X509New := nil; + _X509Free := nil; + _X509NameOneline := nil; + _X509GetSubjectName := nil; + _X509GetIssuerName := nil; + _X509NameHash := nil; + _X509Digest := nil; + _X509print := nil; + _X509SetVersion := nil; + _X509SetPubkey := nil; + _X509SetIssuerName := nil; + _X509NameAddEntryByTxt := nil; + _X509Sign := nil; + _X509GmtimeAdj := nil; + _X509SetNotBefore := nil; + _X509SetNotAfter := nil; + _X509GetSerialNumber := nil; + _EvpPkeyNew := nil; + _EvpPkeyFree := nil; + _EvpPkeyAssign := nil; + _EVPCleanup := nil; + _EvpGetDigestByName := nil; + _SSLeayversion := nil; + _OpenSSLversion := nil; + _ErrErrorString := nil; + _ErrGetError := nil; + _ErrClearError := nil; + _ErrFreeStrings := nil; + _ErrRemoveState := nil; + _OPENSSLaddallalgorithms := nil; + _CRYPTOcleanupAllExData := nil; + _RandScreen := nil; + _BioNew := nil; + _BioFreeAll := nil; + _BioSMem := nil; + _BioCtrlPending := nil; + _BioRead := nil; + _BioWrite := nil; + _d2iPKCS12bio := nil; + _PKCS12parse := nil; + _PKCS12free := nil; + _RsaGenerateKey := nil; + _Asn1UtctimeNew := nil; + _Asn1UtctimeFree := nil; + _Asn1IntegerSet := nil; + _Asn1IntegerGet := nil; {pf} + _SkX509PopFree := nil; {pf} + _i2dX509bio := nil; + _i2dPrivateKeyBio := nil; + + // 3DES functions + _DESsetoddparity := nil; + _DESsetkeychecked := nil; + _DESecbencrypt := nil; + // + _CRYPTOnumlocks := nil; + _CRYPTOsetlockingcallback := nil; +{$ENDIF} +{$ENDIF} + finally + SSLCS.Leave; + end; + Result := True; +end; + +function IsSSLloaded: Boolean; +begin + Result := SSLLoaded; +end; + +initialization +begin + SSLCS:= TCriticalSection.Create; +end; + +finalization +begin +{$IFNDEF CIL} + DestroySSLInterface; +{$ENDIF} + SSLCS.Free; +end; + +end. diff --git a/ssl_streamsec.pas b/ssl_streamsec.pas new file mode 100644 index 0000000..1dc67f9 --- /dev/null +++ b/ssl_streamsec.pas @@ -0,0 +1,539 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.006 | +|==============================================================================| +| Content: SSL support by StreamSecII | +|==============================================================================| +| Copyright (c)1999-2005, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2005. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Henrick Hellström | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII) + +StreamSecII is native pascal library, you not need any external libraries! + +You can tune lot of StreamSecII properties by using your GlobalServer. If you not +using your GlobalServer, then this plugin create own TSimpleTLSInternalServer +instance for each TCP connection. Formore information about GlobalServer usage +refer StreamSecII documentation. + +If you are not using key and certificate by GlobalServer, then you can use +properties of this plugin instead, but this have limited features and +@link(TCustomSSL.KeyPassword) not working properly yet! + +For handling keys and certificates you can use this properties: +@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), +@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), +@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), +@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), +@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats +of keys and certificates refer to StreamSecII documentation. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_streamsec; + +interface + +uses + SysUtils, Classes, + blcksock, synsock, synautil, synacode, + TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base, + SecUtils; + +type + {:@exclude} + TMyTLSSynSockSlave = class(TTLSSynSockSlave) + protected + procedure SetMyTLSServer(const Value: TCustomTLSInternalServer); + function GetMyTLSServer: TCustomTLSInternalServer; + published + property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer; + end; + + {:@abstract(class implementing StreamSecII SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLStreamSec = class(TCustomSSL) + protected + FSlave: TMyTLSSynSockSlave; + FIsServer: Boolean; + FTLSServer: TCustomTLSInternalServer; + FServerCreated: Boolean; + function SSLCheck: Boolean; + function Init(server:Boolean): Boolean; + function DeInit: Boolean; + function Prepare(server:Boolean): Boolean; + procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); + function X500StrToStr(const Prefix: string; const Value: TX500String): string; + function X501NameToStr(const Value: TX501Name): string; + function GetCert: PASN1Struct; + public + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_streamsec) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_streamsec) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + published + {:TLS server for tuning of StreamSecII.} + property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; + end; + +implementation + +{==============================================================================} +procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer); +begin + TLSServer := Value; +end; + +function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer; +begin + Result := TLSServer; +end; + +{==============================================================================} + +constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FSlave := nil; + FIsServer := False; + FTLSServer := nil; +end; + +destructor TSSLStreamSec.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLStreamSec.LibVersion: String; +begin + Result := 'StreamSecII'; +end; + +function TSSLStreamSec.LibName: String; +begin + Result := 'ssl_streamsec'; +end; + +function TSSLStreamSec.SSLCheck: Boolean; +begin + Result := true; + FLastErrorDesc := ''; + if not Assigned(FSlave) then + Exit; + FLastError := FSlave.ErrorCode; + if FLastError <> 0 then + begin + FLastErrorDesc := TlsConst.AlertMsg(FLastError); + end; +end; + +procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); +begin + ExplicitTrust := true; +end; + +function TSSLStreamSec.Init(server:Boolean): Boolean; +var + st: TMemoryStream; + pass: ISecretKey; + ws: WideString; +begin + Result := False; + ws := FKeyPassword; + pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws)); + try + FIsServer := Server; + FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket); + if Assigned(FTLSServer) then + FSlave.MyTLSServer := FTLSServer + else + if Assigned(TLSInternalServer.GlobalServer) then + FSlave.MyTLSServer := TLSInternalServer.GlobalServer + else begin + FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); + FServerCreated := True; + end; + if server then + FSlave.MyTLSServer.ClientOrServer := cosServerSide + else + FSlave.MyTLSServer.ClientOrServer := cosClientSide; + if not FVerifyCert then + begin + FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent; + end; + FSlave.MyTLSServer.Options.VerifyServerName := []; + FSlave.MyTLSServer.Options.Export40Bit := prAllowed; + FSlave.MyTLSServer.Options.Export56Bit := prAllowed; + FSlave.MyTLSServer.Options.RequestClientCertificate := False; + FSlave.MyTLSServer.Options.RequireClientCertificate := False; + if server and FVerifyCert then + begin + FSlave.MyTLSServer.Options.RequestClientCertificate := True; + FSlave.MyTLSServer.Options.RequireClientCertificate := True; + end; + if FCertCAFile <> '' then + FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile); + if FCertCA <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FCertCA); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadRootCertsFromStream(st); + finally + st.free; + end; + end; + if FTrustCertificateFile <> '' then + FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile); + if FTrustCertificate <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FTrustCertificate); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadTrustedCertsFromStream(st); + finally + st.free; + end; + end; + if FPrivateKeyFile <> '' then + FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass); +// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass); + if FPrivateKey <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FPrivateKey); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass); + finally + st.free; + end; + end; + if FCertificateFile <> '' then + FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile); + if FCertificate <> '' then + begin + st := TMemoryStream.Create; + try + WriteStrToStream(st, FCertificate); + st.Seek(0, soFromBeginning); + FSlave.MyTLSServer.LoadMyCertsFromStream(st); + finally + st.free; + end; + end; + if FPFXfile <> '' then + FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); + if server and FServerCreated then + begin + FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; + FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; + FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256; + FSlave.MyTLSServer.Options.SignatureRSA := prPrefer; + FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed; + FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed; + FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer; + FSlave.MyTLSServer.TLSSetupServer; + end; + Result := true; + finally + pass := nil; + end; +end; + +function TSSLStreamSec.DeInit: Boolean; +var + obj: TObject; +begin + Result := True; + if assigned(FSlave) then + begin + FSlave.Close; + if FServerCreated then + obj := FSlave.TLSServer + else + obj := nil; + FSlave.Free; + obj.Free; + FSlave := nil; + end; + FSSLEnabled := false; +end; + +function TSSLStreamSec.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLStreamSec.Connect: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(false) then + begin + FSlave.Open; + SSLCheck; + if FLastError <> 0 then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLStreamSec.Accept: boolean; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(true) then + begin + FSlave.DoConnect; + SSLCheck; + if FLastError <> 0 then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLStreamSec.Shutdown: boolean; +begin + Result := BiShutdown; +end; + +function TSSLStreamSec.BiShutdown: boolean; +begin + DeInit; + Result := True; +end; + +function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + l := len; + FSlave.SendBuf(Buffer^, l, true); + Result := l; + SSLCheck; +end; + +function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +var + l: integer; +begin + l := Len; + Result := FSlave.ReceiveBuf(Buffer^, l); + SSLCheck; +end; + +function TSSLStreamSec.WaitingData: Integer; +begin + Result := 0; + while FSlave.Connected do begin + Result := FSlave.ReceiveLength; + if Result > 0 then + Break; + Sleep(1); + end; +end; + +function TSSLStreamSec.GetSSLVersion: string; +begin + Result := 'SSLv3 or TLSv1'; +end; + +function TSSLStreamSec.GetCert: PASN1Struct; +begin + if FIsServer then + Result := FSlave.GetClientCert + else + Result := FSlave.GetServerCert; +end; + +function TSSLStreamSec.GetPeerSubject: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractSubject(Cert^,XName, false); + Result := X501NameToStr(XName); + end; +end; + +function TSSLStreamSec.GetPeerName: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractSubject(Cert^,XName, false); + Result := XName.commonName.Str; + end; +end; + +function TSSLStreamSec.GetPeerIssuer: string; +var + XName: TX501Name; + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + ExtractIssuer(Cert^, XName, false); + Result := X501NameToStr(XName); + end; +end; + +function TSSLStreamSec.GetPeerFingerprint: string; +var + Cert: PASN1Struct; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + Result := MD5(Cert.ContentAsOctetString); +end; + +function TSSLStreamSec.GetCertInfo: string; +var + Cert: PASN1Struct; + l: Tstringlist; +begin + Result := ''; + Cert := GetCert; + if Assigned(cert) then + begin + l := TStringList.Create; + try + Asn1.RenderAsText(cert^, l, true, true, true, 2); + Result := l.Text; + finally + l.free; + end; + end; +end; + +function TSSLStreamSec.X500StrToStr(const Prefix: string; + const Value: TX500String): string; +begin + if Value.Str = '' then + Result := '' + else + Result := '/' + Prefix + '=' + Value.Str; +end; + +function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string; +begin + Result := X500StrToStr('CN',Value.commonName) + + X500StrToStr('C',Value.countryName) + + X500StrToStr('L',Value.localityName) + + X500StrToStr('ST',Value.stateOrProvinceName) + + X500StrToStr('O',Value.organizationName) + + X500StrToStr('OU',Value.organizationalUnitName) + + X500StrToStr('T',Value.title) + + X500StrToStr('N',Value.name) + + X500StrToStr('G',Value.givenName) + + X500StrToStr('I',Value.initials) + + X500StrToStr('SN',Value.surname) + + X500StrToStr('GQ',Value.generationQualifier) + + X500StrToStr('DNQ',Value.dnQualifier) + + X500StrToStr('E',Value.emailAddress); +end; + + +{==============================================================================} + +initialization + SSLImplementation := TSSLStreamSec; + +finalization + +end. + + diff --git a/sslinux.inc b/sslinux.inc new file mode 100644 index 0000000..00d7e9d --- /dev/null +++ b/sslinux.inc @@ -0,0 +1,1318 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.009 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Linux definition include | +|==============================================================================| +| Copyright (c)1999-2012, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF LINUX} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +interface + +uses + SyncObjs, SysUtils, Classes, + synafpc, + {$IFNDEF FPC} + Libc; + {$ELSE FPC} + libclite; + {$ENDIF ~FPC} + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + WinsockLevel = $0202; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + TSocket = u_int; + TAddrFamily = integer; + + TMemory = pointer; + + +const + DLLStackName = 'libc.so.6'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + +type + DWORD = Integer; + __fd_mask = LongWord; +const + __FD_SETSIZE = 1024; + __NFDBITS = 8 * sizeof(__fd_mask); +type + __fd_set = {packed} record + fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask; + end; + TFDSet = __fd_set; + PFDSet = ^TFDSet; + +const + FIONREAD = $541B; + FIONBIO = $5421; + FIOASYNC = $5452; + +type + PTimeVal = ^TTimeVal; + TTimeVal = packed record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + PInAddr = ^TInAddr; + TInAddr = packed record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = packed record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + 1: (sa_family: u_short; + sa_data: array[0..13] of Char) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = packed record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: u_long; + end; + + PHostEnt = ^THostEnt; + THostent = record + h_name: PChar; + h_aliases: PPChar; + h_addrtype: Integer; + h_length: Cardinal; + case Byte of + 0: (h_addr_list: PPChar); + 1: (h_addr: PPChar); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PChar; + n_aliases: PPChar; + n_addrtype: Integer; + n_net: uint32_t; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PChar; + s_aliases: PPChar; + s_port: Integer; + s_proto: PChar; + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PChar; + p_aliases: ^PChar; + p_proto: u_short; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = 1; { int; IP type of service and precedence. } + IP_TTL = 2; { int; IP time to live. } + IP_HDRINCL = 3; { int; Header is included with data. } + IP_OPTIONS = 4; { ip_opts; IP per-packet options. } + IP_ROUTER_ALERT = 5; { bool } + IP_RECVOPTS = 6; { bool } + IP_RETOPTS = 7; { bool } + IP_PKTINFO = 8; { bool } + IP_PKTOPTIONS = 9; + IP_PMTUDISC = 10; { obsolete name? } + IP_MTU_DISCOVER = 10; { int; see below } + IP_RECVERR = 11; { bool } + IP_RECVTTL = 12; { bool } + IP_RECVTOS = 13; { bool } + IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = 1; + + SO_DEBUG = 1; + SO_REUSEADDR = 2; + SO_TYPE = 3; + SO_ERROR = 4; + SO_DONTROUTE = 5; + SO_BROADCAST = 6; + SO_SNDBUF = 7; + SO_RCVBUF = 8; + SO_KEEPALIVE = 9; + SO_OOBINLINE = 10; + SO_NO_CHECK = 11; + SO_PRIORITY = 12; + SO_LINGER = 13; + SO_BSDCOMPAT = 14; + SO_REUSEPORT = 15; + SO_PASSCRED = 16; + SO_PEERCRED = 17; + SO_RCVLOWAT = 18; + SO_SNDLOWAT = 19; + SO_RCVTIMEO = 20; + SO_SNDTIMEO = 21; +{ Security levels - as per NRL IPv6 - don't actually do anything } + SO_SECURITY_AUTHENTICATION = 22; + SO_SECURITY_ENCRYPTION_TRANSPORT = 23; + SO_SECURITY_ENCRYPTION_NETWORK = 24; + SO_BINDTODEVICE = 25; +{ Socket filtering } + SO_ATTACH_FILTER = 26; + SO_DETACH_FILTER = 27; + + SOMAXCONN = 128; + + IPV6_UNICAST_HOPS = 16; + IPV6_MULTICAST_IF = 17; + IPV6_MULTICAST_HOPS = 18; + IPV6_MULTICAST_LOOP = 19; + IPV6_JOIN_GROUP = 20; + IPV6_LEAVE_GROUP = 21; + + MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $4; + NI_NUMERICHOST = $1; + NI_NAMEREQD = $8; + NI_NUMERICSERV = $2; + NI_DGRAM = $10; + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 10; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = packed record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_addr: PSockAddr; // Binary address. + ai_canonname: PChar; // Canonical name for nodename. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + WSAEINTR = EINTR; + WSAEBADF = EBADF; + WSAEACCES = EACCES; + WSAEFAULT = EFAULT; + WSAEINVAL = EINVAL; + WSAEMFILE = EMFILE; + WSAEWOULDBLOCK = EWOULDBLOCK; + WSAEINPROGRESS = EINPROGRESS; + WSAEALREADY = EALREADY; + WSAENOTSOCK = ENOTSOCK; + WSAEDESTADDRREQ = EDESTADDRREQ; + WSAEMSGSIZE = EMSGSIZE; + WSAEPROTOTYPE = EPROTOTYPE; + WSAENOPROTOOPT = ENOPROTOOPT; + WSAEPROTONOSUPPORT = EPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; + WSAEOPNOTSUPP = EOPNOTSUPP; + WSAEPFNOSUPPORT = EPFNOSUPPORT; + WSAEAFNOSUPPORT = EAFNOSUPPORT; + WSAEADDRINUSE = EADDRINUSE; + WSAEADDRNOTAVAIL = EADDRNOTAVAIL; + WSAENETDOWN = ENETDOWN; + WSAENETUNREACH = ENETUNREACH; + WSAENETRESET = ENETRESET; + WSAECONNABORTED = ECONNABORTED; + WSAECONNRESET = ECONNRESET; + WSAENOBUFS = ENOBUFS; + WSAEISCONN = EISCONN; + WSAENOTCONN = ENOTCONN; + WSAESHUTDOWN = ESHUTDOWN; + WSAETOOMANYREFS = ETOOMANYREFS; + WSAETIMEDOUT = ETIMEDOUT; + WSAECONNREFUSED = ECONNREFUSED; + WSAELOOP = ELOOP; + WSAENAMETOOLONG = ENAMETOOLONG; + WSAEHOSTDOWN = EHOSTDOWN; + WSAEHOSTUNREACH = EHOSTUNREACH; + WSAENOTEMPTY = ENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = EUSERS; + WSAEDQUOT = EDQUOT; + WSAESTALE = ESTALE; + WSAEREMOTE = EREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = HOST_NOT_FOUND; + WSATRY_AGAIN = TRY_AGAIN; + WSANO_RECOVERY = NO_RECOVERY; + WSANO_DATA = -6; + WSABASEERR = 10000; + + EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. } + EAI_NONAME = -2; { NAME or SERVICE is unknown. } + EAI_AGAIN = -3; { Temporary failure in name resolution. } + EAI_FAIL = -4; { Non-recoverable failure in name res. } + EAI_NODATA = -5; { No address associated with NAME. } + EAI_FAMILY = -6; { `ai_family' not supported. } + EAI_SOCKTYPE = -7; { `ai_socktype' not supported. } + EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. } + EAI_ADDRFAMILY = -9; { Address family for NAME not supported. } + EAI_MEMORY = -10; { Memory allocation failure. } + EAI_SYSTEM = -11; { System error returned in `errno'. } + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + cdecl; + TWSACleanup = function: Integer; + cdecl; + TWSAGetLastError = function: Integer; + cdecl; + TGetServByName = function(name, proto: PChar): PServEnt; + cdecl; + TGetServByPort = function(port: Integer; proto: PChar): PServEnt; + cdecl; + TGetProtoByName = function(name: PChar): PProtoEnt; + cdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + cdecl; + TGetHostByName = function(name: PChar): PHostEnt; + cdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + cdecl; + TGetHostName = function(name: PChar; len: Integer): Integer; + cdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + cdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + optlen: Integer): Integer; + cdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + var optlen: Integer): Integer; + cdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + cdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + cdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + cdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + cdecl; + Tntohs = function(netshort: u_short): u_short; + cdecl; + Tntohl = function(netlong: u_long): u_long; + cdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + cdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer; + cdecl; + TInet_ntoa = function(inaddr: TInAddr): PChar; + cdecl; + TInet_addr = function(cp: PChar): u_long; + cdecl; + Thtons = function(hostshort: u_short): u_short; + cdecl; + Thtonl = function(hostlong: u_long): u_long; + cdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + cdecl; + TCloseSocket = function(s: TSocket): Integer; + cdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + cdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + cdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + cdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + cdecl; + + TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + cdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + cdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar; + hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer; + cdecl; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl; +function LSWSACleanup: Integer; cdecl; +function LSWSAGetLastError: Integer; cdecl; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: string; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: TLibHandle = 0; + Libwship6Handle: TLibHandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +var +{$IFNDEF VER1_0} //FTP version 1.0.x + errno_loc: function: PInteger cdecl = nil; +{$ELSE} + errno_loc: function: PInteger = nil; cdecl; +{$ENDIF} + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Linux'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function LSWSACleanup: Integer; +begin + Result := 0; +end; + +function LSWSAGetLastError: Integer; +var + p: PInteger; +begin + p := errno_loc; + Result := p^; +end; + +function __FDELT(Socket: TSocket): Integer; +begin + Result := Socket div __NFDBITS; +end; + +function __FDMASK(Socket: TSocket): __fd_mask; +begin + Result := LongWord(1) shl (Socket mod __NFDBITS); +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket)); +end; + +procedure FD_ZERO(var fdset: TFDSet); +var + I: Integer; +begin + with fdset do + for I := Low(fds_bits) to High(fds_bits) do + fds_bits[I] := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: string; +var + s: string; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pchar(s), Length(s) - 1); + Result := Pchar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): string; +var + p: PChar; + host, serv: string; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen, + PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: string; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(Name); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PChar(host); + IPList.Add(host); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(Port, 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + Result := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + Signal(SIGPIPE, TSignalHandler(SIG_IGN)); + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + errno_loc := GetProcAddress(LibHandle, PChar('__errno_location')); + CloseSocket := GetProcAddress(LibHandle, PChar('close')); + IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl')); + WSAGetLastError := LSWSAGetLastError; + WSAStartup := LSWSAStartup; + WSACleanup := LSWSACleanup; + ssAccept := GetProcAddress(LibHandle, PChar('accept')); + ssBind := GetProcAddress(LibHandle, PChar('bind')); + ssConnect := GetProcAddress(LibHandle, PChar('connect')); + ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); + ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname')); + GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); + Htonl := GetProcAddress(LibHandle, PChar('htonl')); + Htons := GetProcAddress(LibHandle, PChar('htons')); + Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); + Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); + Listen := GetProcAddress(LibHandle, PChar('listen')); + Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); + Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); + ssRecv := GetProcAddress(LibHandle, PChar('recv')); + ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); + Select := GetProcAddress(LibHandle, PChar('select')); + ssSend := GetProcAddress(LibHandle, PChar('send')); + ssSendTo := GetProcAddress(LibHandle, PChar('sendto')); + SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); + ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); + Socket := GetProcAddress(LibHandle, PChar('socket')); + GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); + GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); + GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); + GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); + GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); + GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); + ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname')); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); + FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); + GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/ssos2ws1.inc b/ssos2ws1.inc new file mode 100644 index 0000000..9a07e47 --- /dev/null +++ b/ssos2ws1.inc @@ -0,0 +1,1843 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: Socket Independent Platform Layer - OS/2 winsock1 | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$MACRO ON} + +{$IFNDEF ODIN} + {$DEFINE WINSOCK1} + {$DEFINE PMWSOCK} +{$ENDIF ODIN} + +{$IFDEF PMWSOCK} + {$DEFINE extdecl := cdecl} +{$ELSE PMWSOCK} + {$DEFINE extdecl := stdcall} +{$ENDIF PMWSOCK} + +//{$DEFINE WINSOCK1} +{Note about define WINSOCK1: +If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install update. +} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT '/* EDE 2003-02-19 */' *) + (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) + (*$HPPEMIT '#undef h_addr' *) + (*$HPPEMIT '#undef IOCPARM_MASK' *) + (*$HPPEMIT '#undef FD_SETSIZE' *) + (*$HPPEMIT '#undef IOC_VOID' *) + (*$HPPEMIT '#undef IOC_OUT' *) + (*$HPPEMIT '#undef IOC_IN' *) + (*$HPPEMIT '#undef IOC_INOUT' *) + (*$HPPEMIT '#undef FIONREAD' *) + (*$HPPEMIT '#undef FIONBIO' *) + (*$HPPEMIT '#undef FIOASYNC' *) + (*$HPPEMIT '#undef IPPROTO_IP' *) + (*$HPPEMIT '#undef IPPROTO_ICMP' *) + (*$HPPEMIT '#undef IPPROTO_IGMP' *) + (*$HPPEMIT '#undef IPPROTO_TCP' *) + (*$HPPEMIT '#undef IPPROTO_UDP' *) + (*$HPPEMIT '#undef IPPROTO_RAW' *) + (*$HPPEMIT '#undef IPPROTO_MAX' *) + (*$HPPEMIT '#undef INADDR_ANY' *) + (*$HPPEMIT '#undef INADDR_LOOPBACK' *) + (*$HPPEMIT '#undef INADDR_BROADCAST' *) + (*$HPPEMIT '#undef INADDR_NONE' *) + (*$HPPEMIT '#undef INVALID_SOCKET' *) + (*$HPPEMIT '#undef SOCKET_ERROR' *) + (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) + (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) + (*$HPPEMIT '#undef IP_OPTIONS' *) + (*$HPPEMIT '#undef IP_TOS' *) + (*$HPPEMIT '#undef IP_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_IF' *) + (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) + (*$HPPEMIT '#undef SOL_SOCKET' *) + (*$HPPEMIT '#undef SO_DEBUG' *) + (*$HPPEMIT '#undef SO_ACCEPTCONN' *) + (*$HPPEMIT '#undef SO_REUSEADDR' *) + (*$HPPEMIT '#undef SO_KEEPALIVE' *) + (*$HPPEMIT '#undef SO_DONTROUTE' *) + (*$HPPEMIT '#undef SO_BROADCAST' *) + (*$HPPEMIT '#undef SO_USELOOPBACK' *) + (*$HPPEMIT '#undef SO_LINGER' *) + (*$HPPEMIT '#undef SO_OOBINLINE' *) + (*$HPPEMIT '#undef SO_DONTLINGER' *) + (*$HPPEMIT '#undef SO_SNDBUF' *) + (*$HPPEMIT '#undef SO_RCVBUF' *) + (*$HPPEMIT '#undef SO_SNDLOWAT' *) + (*$HPPEMIT '#undef SO_RCVLOWAT' *) + (*$HPPEMIT '#undef SO_SNDTIMEO' *) + (*$HPPEMIT '#undef SO_RCVTIMEO' *) + (*$HPPEMIT '#undef SO_ERROR' *) + (*$HPPEMIT '#undef SO_OPENTYPE' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) + (*$HPPEMIT '#undef SO_MAXDG' *) + (*$HPPEMIT '#undef SO_MAXPATHDG' *) + (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) + (*$HPPEMIT '#undef SO_CONNECT_TIME' *) + (*$HPPEMIT '#undef SO_TYPE' *) + (*$HPPEMIT '#undef SOCK_STREAM' *) + (*$HPPEMIT '#undef SOCK_DGRAM' *) + (*$HPPEMIT '#undef SOCK_RAW' *) + (*$HPPEMIT '#undef SOCK_RDM' *) + (*$HPPEMIT '#undef SOCK_SEQPACKET' *) + (*$HPPEMIT '#undef TCP_NODELAY' *) + (*$HPPEMIT '#undef AF_UNSPEC' *) + (*$HPPEMIT '#undef SOMAXCONN' *) + (*$HPPEMIT '#undef AF_INET' *) + (*$HPPEMIT '#undef AF_MAX' *) + (*$HPPEMIT '#undef PF_UNSPEC' *) + (*$HPPEMIT '#undef PF_INET' *) + (*$HPPEMIT '#undef PF_MAX' *) + (*$HPPEMIT '#undef MSG_OOB' *) + (*$HPPEMIT '#undef MSG_PEEK' *) + (*$HPPEMIT '#undef WSABASEERR' *) + (*$HPPEMIT '#undef WSAEINTR' *) + (*$HPPEMIT '#undef WSAEBADF' *) + (*$HPPEMIT '#undef WSAEACCES' *) + (*$HPPEMIT '#undef WSAEFAULT' *) + (*$HPPEMIT '#undef WSAEINVAL' *) + (*$HPPEMIT '#undef WSAEMFILE' *) + (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) + (*$HPPEMIT '#undef WSAEINPROGRESS' *) + (*$HPPEMIT '#undef WSAEALREADY' *) + (*$HPPEMIT '#undef WSAENOTSOCK' *) + (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) + (*$HPPEMIT '#undef WSAEMSGSIZE' *) + (*$HPPEMIT '#undef WSAEPROTOTYPE' *) + (*$HPPEMIT '#undef WSAENOPROTOOPT' *) + (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) + (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) + (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEADDRINUSE' *) + (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) + (*$HPPEMIT '#undef WSAENETDOWN' *) + (*$HPPEMIT '#undef WSAENETUNREACH' *) + (*$HPPEMIT '#undef WSAENETRESET' *) + (*$HPPEMIT '#undef WSAECONNABORTED' *) + (*$HPPEMIT '#undef WSAECONNRESET' *) + (*$HPPEMIT '#undef WSAENOBUFS' *) + (*$HPPEMIT '#undef WSAEISCONN' *) + (*$HPPEMIT '#undef WSAENOTCONN' *) + (*$HPPEMIT '#undef WSAESHUTDOWN' *) + (*$HPPEMIT '#undef WSAETOOMANYREFS' *) + (*$HPPEMIT '#undef WSAETIMEDOUT' *) + (*$HPPEMIT '#undef WSAECONNREFUSED' *) + (*$HPPEMIT '#undef WSAELOOP' *) + (*$HPPEMIT '#undef WSAENAMETOOLONG' *) + (*$HPPEMIT '#undef WSAEHOSTDOWN' *) + (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) + (*$HPPEMIT '#undef WSAENOTEMPTY' *) + (*$HPPEMIT '#undef WSAEPROCLIM' *) + (*$HPPEMIT '#undef WSAEUSERS' *) + (*$HPPEMIT '#undef WSAEDQUOT' *) + (*$HPPEMIT '#undef WSAESTALE' *) + (*$HPPEMIT '#undef WSAEREMOTE' *) + (*$HPPEMIT '#undef WSASYSNOTREADY' *) + (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) + (*$HPPEMIT '#undef WSANOTINITIALISED' *) + (*$HPPEMIT '#undef WSAEDISCON' *) + (*$HPPEMIT '#undef WSAENOMORE' *) + (*$HPPEMIT '#undef WSAECANCELLED' *) + (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) + (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) + (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) + (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) + (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSA_E_NO_MORE' *) + (*$HPPEMIT '#undef WSA_E_CANCELLED' *) + (*$HPPEMIT '#undef WSAEREFUSED' *) + (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) + (*$HPPEMIT '#undef HOST_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATRY_AGAIN' *) + (*$HPPEMIT '#undef TRY_AGAIN' *) + (*$HPPEMIT '#undef WSANO_RECOVERY' *) + (*$HPPEMIT '#undef NO_RECOVERY' *) + (*$HPPEMIT '#undef WSANO_DATA' *) + (*$HPPEMIT '#undef NO_DATA' *) + (*$HPPEMIT '#undef WSANO_ADDRESS' *) + (*$HPPEMIT '#undef ENAMETOOLONG' *) + (*$HPPEMIT '#undef ENOTEMPTY' *) + (*$HPPEMIT '#undef FD_CLR' *) + (*$HPPEMIT '#undef FD_ISSET' *) + (*$HPPEMIT '#undef FD_SET' *) + (*$HPPEMIT '#undef FD_ZERO' *) + (*$HPPEMIT '#undef NO_ADDRESS' *) + (*$HPPEMIT '#undef ADDR_ANY' *) + (*$HPPEMIT '#undef SO_GROUP_ID' *) + (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) + (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) + (*$HPPEMIT '#undef PVD_CONFIG' *) + (*$HPPEMIT '#undef AF_INET6' *) + (*$HPPEMIT '#undef PF_INET6' *) +{$ENDIF} + +{$IFDEF FPC} + {$IFDEF WIN32} + {$ALIGN OFF} + {$ELSE} + {$PACKRECORDS C} + {$ENDIF} +{$ELSE} + {$IFDEF WIN64} + {$ALIGN ON} + {$MINENUMSIZE 4} + {$ELSE} + {$MINENUMSIZE 4} + {$ALIGN OFF} + {$ENDIF} +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, Classes, +{$IFDEF OS2} + Sockets, Dynlibs +{$ELSE OS2} + Windows +{$ENDIF OS2} +; + +function InitSocketInterface(stack: String): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type +{$IFDEF OS2} + Bool = longint; +{$ENDIF OS2} + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; +{$IFDEF FPC} + TSocket = ptruint; +{$ELSE} + {$IFDEF WIN64} + TSocket = UINT_PTR; + {$ELSE} + TSocket = u_int; + {$ENDIF} +{$ENDIF} + TAddrFamily = integer; + + TMemory = pointer; + +const + {$IFDEF WINCE} + DLLStackName = 'ws2.dll'; + {$ELSE} + {$IFDEF WINSOCK1} + {$IFDEF OS2} + {$IFDEF DAPWSOCK} + DLLStackName = 'dapwsock.dll'; + {$ELSE DAPWSOCK} + DLLStackName = 'pmwsock.dll'; + {$ENDIF DAPWSOCK} + {$ELSE OS2} + DLLStackName = 'wsock32.dll'; + {$ENDIF OS2} + {$ELSE} + DLLStackName = 'ws2_32.dll'; + {$ENDIF} + {$ENDIF} + DLLwship6 = 'wship6.dll'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + + +const + FD_SETSIZE = 64; +type + PFDSet = ^TFDSet; + TFDSet = record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + + PInAddr = ^TInAddr; + TInAddr = record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + 1: (sa_family: u_short; + sa_data: array[0..13] of byte) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: integer; + end; + + PHostEnt = ^THostEnt; + THostEnt = record + h_name: PAnsiChar; + h_aliases: ^PAnsiChar; +{$IFDEF PMWSOCK} + h_addrtype: longint; + h_length: longint; +{$ELSE PMWSOCK} + h_addrtype: Smallint; + h_length: Smallint; +{$ENDIF PMWSOCK} + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; +{$IFDEF PMWSOCK} + n_addrtype: longint; +{$ELSE PMWSOCK} + n_addrtype: Smallint; +{$ENDIF PMWSOCK} + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; +{$ifdef WIN64} + s_proto: PAnsiChar; + s_port: Smallint; +{$else} +{$IFDEF PMWSOCK} + s_port: longint; +{$ELSE PMWSOCK} + s_port: Smallint; +{$ENDIF PMWSOCK} + s_proto: PAnsiChar; +{$endif} + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PAnsiChar; + p_aliases: ^PAnsichar; +{$IFDEF PMWSOCK} + p_proto: longint; +{$ELSE PMWSOCK} + p_proto: Smallint; +{$ENDIF PMWSOCK} + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$IFDEF WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$ENDIF} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PAnsiChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = record +{$IFDEF PMWSOCK} + l_onoff: longint; + l_linger: longint; +{$ELSE PMWSOCK} + l_onoff: u_short; + l_linger: u_short; +{$ENDIF PMWSOCK} + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = record + wVersion: Word; + wHighVersion: Word; +{$ifdef win64} + iMaxSockets : Word; + iMaxUdpDg : Word; + lpVendorInfo : PAnsiChar; + szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; +{$else} + szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PAnsiChar; +{$endif} + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + extdecl; + TWSACleanup = function: Integer; + extdecl; + TWSAGetLastError = function: Integer; + extdecl; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; + extdecl; + TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; + extdecl; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; + extdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + extdecl; + TGetHostByName = function(name: PAnsiChar): PHostEnt; + extdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + extdecl; + TGetHostName = function(name: PAnsiChar; len: Integer): Integer; + extdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + extdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; + extdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; + extdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + extdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + extdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + extdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + extdecl; + Tntohs = function(netshort: u_short): u_short; + extdecl; + Tntohl = function(netlong: u_long): u_long; + extdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + extdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; + extdecl; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; + extdecl; + TInet_addr = function(cp: PAnsiChar): u_long; + extdecl; + Thtons = function(hostshort: u_short): u_short; + extdecl; + Thtonl = function(hostlong: u_long): u_long; + extdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + extdecl; + TCloseSocket = function(s: TSocket): Integer; + extdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + extdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + extdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + extdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + extdecl; + + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + extdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + extdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; + extdecl; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + extdecl; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + extdecl; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; +{$IFDEF OS2} + ssShutdown: TShutdown = nil; + ssSetSockOpt: TSetSockOpt = nil; + ssGetSockOpt: TGetSockOpt = nil; +{$ELSE OS2} + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; +{$ENDIF OS2} + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; +{$IFDEF OS2} + ssListen: TListen = nil; + ssIoctlSocket: TIoctlSocket = nil; +{$ELSE OS2} + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; +{$ENDIF OS2} + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; +{$IFDEF OS2} + ssCloseSocket: TCloseSocket = nil; +{$ELSE OS2} + CloseSocket: TCloseSocket = nil; +{$ENDIF OS2} + ssBind: TBind = nil; + ssAccept: TAccept = nil; +{$IFDEF OS2} + ssSocket: TTSocket = nil; +{$ELSE OS2} + Socket: TTSocket = nil; +{$ENDIF OS2} + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +{$IFDEF OS2} + ss__WSAFDIsSet: T__WSAFDIsSet = nil; + + ssWSAIoctl: TWSAIoctl = nil; +{$ELSE OS2} + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; +{$ENDIF OS2} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: AnsiString; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): AnsiString; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +{$IFDEF OS2} +function Socket (af, Struc, Protocol: Integer): TSocket; +function Shutdown (s: TSocket; how: Integer): Integer; +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +function Listen (s: TSocket; backlog: Integer): Integer; +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +function CloseSocket (s: TSocket): Integer; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +{$ENDIF OS2} + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + I: Integer; +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + I := 0; + while I < FDSet.fd_count do + begin + if FDSet.fd_array[I] = Socket then + begin + while I < FDSet.fd_count - 1 do + begin + FDSet.fd_array[I] := FDSet.fd_array[I + 1]; + Inc(I); + end; + Dec(FDSet.fd_count); + Break; + end; + Inc(I); + end; +end; + +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + Result := __WSAFDIsSet(Socket, FDSet) +{$IFDEF OS2} + <> 0 +{$ENDIF OS2} ; +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + if FDSet.fd_count < FD_SETSIZE then + begin + FDSet.fd_array[FDSet.fd_count] := Socket; + Inc(FDSet.fd_count); + end; +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: AnsiString; +var + s: AnsiString; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pAnsichar(s), Length(s) - 1); + Result := PAnsichar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(addr); +{$IFDEF OS2} + Result := TSocket (EMXSocket (cInt (ssAccept (S, @Addr, X)))); +{$ELSE OS2} + Result := ssAccept(s, @addr, x); +{$ENDIF OS2} +end; + +{$IFDEF OS2} +function Shutdown (s: TSocket; how: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Shutdown := ssShutdown (s, how); +end; + +function Socket (af, Struc, Protocol: Integer): TSocket; +begin + Socket := TSocket (EMXSocket (cInt (ssSocket (af, Struc, Protocol)))); +end; + +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + SetSockOpt := ssSetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + GetSockOpt := ssGetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function Listen (s: TSocket; backlog: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Listen := ssListen (S, BackLog); +end; + +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + IOCtlSocket := ssIOCtlSocket (S, Cmd, Arg); +end; + +function CloseSocket (s: TSocket): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + CloseSocket := ssCloseSocket (S); +end; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; +begin + S := TSocket (NativeSocket (cInt (S))); + __WSAFDIsSet := ss__WSAFDIsSet (S, FDSet); +end; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +begin + S := TSocket (NativeSocket (cInt (S))); + WSAIOCtl := ssWSAIOCtl (S, dwIoControlCode, lpvInBuffer, cbInBuffer, + lpvOutBuffer, cbOutBuffer, lpcbBytesReturned, lpOverlapped, + lpCompletionRoutine); +end; +{$ENDIF OS2} + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PAnsiChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): AnsiString; +var + p: PAnsiChar; + host, serv: AnsiString; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, + PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: String; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PAnsiChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(string(Name)); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PAnsiChar(host); + IPList.Add(string(host)); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(string(Port), 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PAnsiChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: String): Boolean; +begin + Result := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin +{$IFDEF OS2} + ssWSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + ss__WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + ssCloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + ssIoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ELSE OS2} + WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ENDIF OS2} + WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); + WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); + WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); + ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); + ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); + ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); + ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); + ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); +{$IFDEF OS2} + ssGetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ELSE OS2} + GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ENDIF OS2} + Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); + Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); + Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); + Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); +{$IFDEF OS2} + ssListen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ELSE OS2} + Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ENDIF OS2} + Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); + Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); + ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); + ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); + Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); + ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); + ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); +{$IFDEF OS2} + ssSetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ssShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + ssSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ELSE OS2} + SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ENDIF OS2} + GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); + GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); + GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); + GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); + GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); + GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); + ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo'))); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + if not SockEnhancedApi then + begin + LibWship6Handle := LoadLibrary(PChar(DLLWship6)); + if LibWship6Handle <> 0 then + begin + GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo'))); + SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + end; + end; +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; \ No newline at end of file diff --git a/ssposix.inc b/ssposix.inc new file mode 100644 index 0000000..b275380 --- /dev/null +++ b/ssposix.inc @@ -0,0 +1,1116 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.004 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Delphi Posix definition include | +|==============================================================================| +| Copyright (c)2006-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2006-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Radek Cervinka | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF POSIX} +{for delphi XE2+} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{ +note RC: +partially compatible with NextGen Delphi compiler - iOS + + +} + + +interface + +uses + SyncObjs, SysUtils, Classes, synabyte, + Posix.SysSocket, Posix.SysSelect, Posix.SysTime, Posix.NetinetIn, + Posix.StrOpts, Posix.Errno, Posix.Signal; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cBroadcast = '255.255.255.255'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; + +type + TSocket = longint; + TAddrFamily = integer; + + TMemory = pointer; + + +type + TFDSet = fd_set; + PFDSet = Pfd_set; + Ptimeval = Posix.SysTime.ptimeval; + Ttimeval = Posix.SysTime.timeval; + +const +{$IFDEF ANDROID} + FIONREAD = Posix.StrOpts.FIONREAD; +{$ELSE} + {$IFDEF LINUX} + FIONREAD = $541B; + FIONBIO = $5421; + FIOASYNC = $5452; + {$ELSE} + FIONREAD = $4004667F; + FIONBIO = $8004667E; //OSX FIONBIO = Posix.StrOpts.FIONBIO; + FIOASYNC = $8004667D; //OSX FIOASYNC = Posix.StrOpts.FIOASYNC; // not defined in XE2 + {$ENDIF} +{$ENDIF} + +const + IPPROTO_IP = Posix.NetinetIn.IPPROTO_IP; { Dummy } + IPPROTO_ICMP = Posix.NetinetIn.IPPROTO_ICMP; { Internet Control Message Protocol } + IPPROTO_IGMP = Posix.NetinetIn.IPPROTO_IGMP; { Internet Group Management Protocol} + IPPROTO_TCP = Posix.NetinetIn.IPPROTO_TCP; { TCP } + IPPROTO_UDP = Posix.NetinetIn.IPPROTO_UDP; { User Datagram Protocol } + IPPROTO_IPV6 = Posix.NetinetIn.IPPROTO_IPV6; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = Posix.NetinetIn.IPPROTO_RAW; + IPPROTO_MAX = Posix.NetinetIn.IPPROTO_MAX; + +type + PInAddr = ^TInAddr; + TInAddr = Posix.NetinetIn.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = Posix.NetinetIn.sockaddr_in; + + + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + + PInAddr6 = ^TInAddr6; + TInAddr6 = Posix.NetinetIn.in6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = Posix.NetinetIn.sockaddr_in6; + + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = Posix.NetinetIn.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = Posix.NetinetIn.IP_TTL; { int; IP time to live. } + IP_HDRINCL = Posix.NetinetIn.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = Posix.NetinetIn.IP_OPTIONS; { ip_opts; IP per-packet options. } +// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } + IP_RECVOPTS = Posix.NetinetIn.IP_RECVOPTS; { bool } + IP_RETOPTS = Posix.NetinetIn.IP_RETOPTS; { bool } +// IP_PKTINFO = sockets.IP_PKTINFO; { bool } +// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; +// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } +// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } +// IP_RECVERR = sockets.IP_RECVERR; { bool } +// IP_RECVTTL = sockets.IP_RECVTTL; { bool } +// IP_RECVTOS = sockets.IP_RECVTOS; { bool } + IP_MULTICAST_IF = Posix.NetinetIn.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = Posix.NetinetIn.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = Posix.NetinetIn.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = Posix.NetinetIn.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = Posix.NetinetIn.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = Posix.SysSocket.SOL_SOCKET; + + SO_DEBUG = Posix.SysSocket.SO_DEBUG; + SO_REUSEADDR = Posix.SysSocket.SO_REUSEADDR; + SO_TYPE = Posix.SysSocket.SO_TYPE; + SO_ERROR = Posix.SysSocket.SO_ERROR; + SO_DONTROUTE = Posix.SysSocket.SO_DONTROUTE; + SO_BROADCAST = Posix.SysSocket.SO_BROADCAST; + SO_SNDBUF = Posix.SysSocket.SO_SNDBUF; + SO_RCVBUF = Posix.SysSocket.SO_RCVBUF; + SO_KEEPALIVE = Posix.SysSocket.SO_KEEPALIVE; + SO_OOBINLINE = Posix.SysSocket.SO_OOBINLINE; +// SO_NO_CHECK = SysSocket.SO_NO_CHECK; +// SO_PRIORITY = SysSocket.SO_PRIORITY; + SO_LINGER = Posix.SysSocket.SO_LINGER; +// SO_BSDCOMPAT = SysSocket.SO_BSDCOMPAT; +// SO_REUSEPORT = SysSocket.SO_REUSEPORT; +// SO_PASSCRED = SysSocket.SO_PASSCRED; +// SO_PEERCRED = SysSocket.SO_PEERCRED; + SO_RCVLOWAT = Posix.SysSocket.SO_RCVLOWAT; + SO_SNDLOWAT = Posix.SysSocket.SO_SNDLOWAT; + SO_RCVTIMEO = Posix.SysSocket.SO_RCVTIMEO; + SO_SNDTIMEO = Posix.SysSocket.SO_SNDTIMEO; +{ Security levels - as per NRL IPv6 - don't actually do anything } +// SO_SECURITY_AUTHENTICATION = SysSocket.SO_SECURITY_AUTHENTICATION; +// SO_SECURITY_ENCRYPTION_TRANSPORT = SysSocket.SO_SECURITY_ENCRYPTION_TRANSPORT; +// SO_SECURITY_ENCRYPTION_NETWORK = SysSocket.SO_SECURITY_ENCRYPTION_NETWORK; +// SO_BINDTODEVICE = SysSocket.SO_BINDTODEVICE; +{ Socket filtering } +// SO_ATTACH_FILTER = SysSocket.SO_ATTACH_FILTER; +// SO_DETACH_FILTER = SysSocket.SO_DETACH_FILTER; + + SOMAXCONN = 1024; + + IPV6_UNICAST_HOPS = Posix.NetinetIn.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = Posix.NetinetIn.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = Posix.NetinetIn.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = Posix.NetinetIn.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = Posix.NetinetIn.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = Posix.NetinetIn.IPV6_LEAVE_GROUP; + +const + SOCK_STREAM = Posix.SysSocket.SOCK_STREAM;// 1; { stream socket } + SOCK_DGRAM = Posix.SysSocket.SOCK_DGRAM;// 2; { datagram socket } + SOCK_RAW = Posix.SysSocket.SOCK_RAW;// 3; { raw-protocol interface } + SOCK_RDM = Posix.SysSocket.SOCK_RDM;// 4; { reliably-delivered message } + SOCK_SEQPACKET = Posix.SysSocket.SOCK_SEQPACKET;// 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; //netinettcp.pas + +{ Address families. } + + AF_UNSPEC = Posix.SysSocket.AF_UNSPEC;// 0; { unspecified } + AF_INET = Posix.SysSocket.AF_INET; // 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = Posix.SysSocket.AF_INET6; // !! 30 { Internetwork Version 6 } + AF_MAX = Posix.SysSocket.AF_MAX; // !! - variable by OS + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = Posix.SysSocket.linger; + +const + + MSG_OOB = Posix.SysSocket.MSG_OOB; // Process out-of-band data. + MSG_PEEK = Posix.SysSocket.MSG_PEEK; // Peek at incoming messages. + {$IFDEF MACOS} + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + // Works under MAC OS X, but is undocumented, + // So FPC doesn't include it + {$ELSE} + MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + {$ENDIF} + +const + WSAEINTR = EINTR; + WSAEBADF = EBADF; + WSAEACCES = EACCES; + WSAEFAULT = EFAULT; + WSAEINVAL = EINVAL; + WSAEMFILE = EMFILE; + WSAEWOULDBLOCK = EWOULDBLOCK; + WSAEINPROGRESS = EINPROGRESS; + WSAEALREADY = EALREADY; + WSAENOTSOCK = ENOTSOCK; + WSAEDESTADDRREQ = EDESTADDRREQ; + WSAEMSGSIZE = EMSGSIZE; + WSAEPROTOTYPE = EPROTOTYPE; + WSAENOPROTOOPT = ENOPROTOOPT; + WSAEPROTONOSUPPORT = EPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; + WSAEOPNOTSUPP = EOPNOTSUPP; + WSAEPFNOSUPPORT = EPFNOSUPPORT; + WSAEAFNOSUPPORT = EAFNOSUPPORT; + WSAEADDRINUSE = EADDRINUSE; + WSAEADDRNOTAVAIL = EADDRNOTAVAIL; + WSAENETDOWN = ENETDOWN; + WSAENETUNREACH = ENETUNREACH; + WSAENETRESET = ENETRESET; + WSAECONNABORTED = ECONNABORTED; + WSAECONNRESET = ECONNRESET; + WSAENOBUFS = ENOBUFS; + WSAEISCONN = EISCONN; + WSAENOTCONN = ENOTCONN; + WSAESHUTDOWN = ESHUTDOWN; + WSAETOOMANYREFS = ETOOMANYREFS; + WSAETIMEDOUT = ETIMEDOUT; + WSAECONNREFUSED = ECONNREFUSED; + WSAELOOP = ELOOP; + WSAENAMETOOLONG = ENAMETOOLONG; + WSAEHOSTDOWN = EHOSTDOWN; + WSAEHOSTUNREACH = EHOSTUNREACH; + WSAENOTEMPTY = ENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = EUSERS; + WSAEDQUOT = EDQUOT; + WSAESTALE = ESTALE; + WSAEREMOTE = EREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = 1; + WSATRY_AGAIN = 2; + WSANO_RECOVERY = 3; + WSANO_DATA = -6; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); + +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + {$IF defined(MACOS32) OR defined(IOS))} + sin_len : UInt8; + {$endif} + + case integer of + 0: (AddressFamily: sa_family_t); + 1: ( + case sin_family: sa_family_t of + AF_INET: (sin_port: word; + sin_addr: TInAddr; + sin_zero: array[0..7] of Byte); + AF_INET6: (sin6_port: word; + sin6_flowinfo: longword; + sin6_addr: TInAddr6; + sin6_scope_id: longword); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; + function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; + function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; + function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: word): word; + function ntohl(netlong: longword): longword; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: Integer; var arg: integer): Integer; + function htons(hostshort: word): word; + function htonl(hostlong: longword): longword; + function GetSockName(s: TSocket; var name: TVarSin): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; + function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + + +{==============================================================================} +implementation +uses + Posix.Base, Posix.Unistd, Posix.ArpaInet, Posix.NetDB; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_UNSPECIFIED(a^); +{ Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));} +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_LOOPBACK(a^); +{ Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));} +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_LINKLOCAL(a^); +{ Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));} +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_SITELOCAL(a^); +// Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_MULTICAST(a^); +// Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s6_addr[15] := 1; +end; + +{=============================================================================} + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Posix by Delphi'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := Posix.Errno.errno; +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := __FD_ISSET(socket, fdset); +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + __FD_SET(Socket, fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + __FD_CLR(Socket, fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + __FD_ZERO(fdset); +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +var + sa: sockaddr absolute addr; +begin + Result := Posix.SysSocket.Bind(s, sa, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +var + sa: sockaddr absolute name; +begin + Result := Posix.SysSocket.Connect(s, sa, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: socklen_t; + address : sockaddr absolute name; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := Posix.SysSocket.GetSockName(s, address, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: socklen_t; + address : sockaddr absolute name; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := Posix.SysSocket.GetPeerName(s, address, Len); +end; + +function GetHostName: string; +var + name: TBytes; +begin + SetLength(name, 256); + fillchar(name[0],sizeof(name),0); + if Posix.Unistd.GetHostName(@name[0], length(name))=0 then + result := Uppercase(StringOf(name)) else + result := 'LOCALHOST'; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := Posix.SysSocket.Send(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := Posix.SysSocket.Recv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +var + sa: sockaddr absolute addrto; +begin + Result := Posix.SysSocket.SendTo(s, Buf^, len, flags, sa, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: socklen_t; + address : sockaddr absolute from; +begin + x := SizeOf(from); + Result := Posix.SysSocket.RecvFrom(s, Buf^, len, flags, address, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: socklen_t; + address : sockaddr absolute addr; +begin + x := SizeOf(addr); + Result := Posix.SysSocket.Accept(s, address, x); +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := Posix.SysSocket.Shutdown(s, how); +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := Posix.SysSocket.setsockopt(s, level, optname, pointer(optval), optlen); +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +var + x: socklen_t; +begin + x := optlen; + Result := Posix.SysSocket.getsockopt(s, level, optname, pointer(optval), x); + optlen := x; +end; + +function ntohs(netshort: word): word; +begin + Result := Posix.ArpaInet.ntohs(NetShort); +end; + +function ntohl(netlong: longword): longword; +begin + Result := Posix.ArpaInet.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if Posix.SysSocket.Listen(s, backlog) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: Integer; var arg: integer): Integer; +begin + Result := Posix.StrOpts.Ioctl(s, cmd, @arg); +end; + +function htons(hostshort: word): word; +begin + Result := Posix.ArpaInet.htons(Hostshort); +end; + +function htonl(hostlong: longword): longword; +begin + Result := Posix.ArpaInet.htonl(HostLong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := Posix.Unistd.__close(s); +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + Result := Posix.SysSocket.Socket(af, struc, protocol); +end; + +function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + Result := Posix.SysSelect.Select(nfds, readfds, writefds, exceptfds, timeout); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function gethostbyname(name: pointer): PHostEnt; cdecl; + external libc name _PU + 'gethostbyname'; + +function gethostbyaddr(var addr; len: socklen_t; atype: integer): PHostEnt; cdecl; + external libc name _PU + 'gethostbyaddr'; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: AddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: string; Hints: AddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), nil, Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr); + end + else + begin + Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + FreeAddrInfo(Addr^); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + {$IFDEF NEXTGEN} + ServEnt := GetServByName(MarshaledAString(TMarshal.AsAnsi(Port)), ProtoEnt^.p_name); + {$ELSE} + ServEnt := GetServByName(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name); + {$ENDIF} + if ServEnt = nil then + Sin.sin_port := htons(StrToIntDef(Port, 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := UInt32(INADDR_BROADCAST) + else + begin + {$IFDEF NEXTGEN} + Sin.sin_addr.s_addr := inet_addr(MarshaledAString(TMarshal.AsAnsi(IP))); + {$ELSE} + Sin.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(IP))); + {$ENDIF} + if Sin.sin_addr.s_addr = UInt32(INADDR_NONE) then + begin + {$IFDEF NEXTGEN} + HostEnt := GetHostByName(MarshaledAString(TMarshal.AsAnsi(IP))); + {$ELSE} + HostEnt := GetHostByName(PAnsiChar(AnsiString(IP))); + {$ENDIF} + Result := WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := UInt32(HostEnt.h_addr_list); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): string; +var + p: pointer; + hostlen, servlen: integer; + r: integer; + sa:sockaddr absolute Sin; + byHost, byServ: TBytes; + HostWrapper, ServWrapper: Pointer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := string(p); + end + else + begin + // NEXTGEN compatible + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + Setlength(byHost, hostLen); + Setlength(byServ, hostLen); + HostWrapper := @byHost[0]; + ServWrapper := @byServ[0]; + r := getnameinfo(sa, SizeOfVarSin(sin), HostWrapper, hostlen, + ServWrapper, servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := MarshaledAString(HostWrapper); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: AddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: TBytes; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: UINT32; + PAdrPtr: PaPInAddr; + i: Integer; + s: string; + InAddr: TInAddr; + aby:TArray; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + {$IFDEF NEXTGEN} + IP := inet_addr(MarshaledAString(TMarshal.AsAnsi(Name))); + {$ELSE} + IP := inet_addr(PAnsiChar(AnsiString(Name))); + {$ENDIF} + if IP = UINT32(INADDR_NONE) then + begin + SynSockCS.Enter; + try + {$IFDEF NEXTGEN} + RemoteHost := GetHostByName(MarshaledAString(TMarshal.AsAnsi(Name))); + {$ELSE} + RemoteHost := GetHostByName(PAnsiChar(AnsiString(Name))); + {$ENDIF} + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + aby := TArray(Cardinal(InAddr)); + s := Format('%d.%d.%d.%d', [aby[0], aby[1], + aby[2], aby[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(Name); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(Name)), nil, Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr^, AddrNext^.ai_addrlen, + @host[0], hostlen, @serv[0], servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + IPList.Add(StringOf(host)); + SetLength(host, 0); + SetLength(serv, 0); + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + FreeAddrInfo(Addr^); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: AddrInfo; + Addr: PAddrInfo; + _Addr: AddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := GetServByName(MarshaledAString(TMarshal.AsAnsi(Port)), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(Port, 0) + else + Result := htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := htons(Addr^.ai_addr^.sa_data[0]); // port + if Addr^.ai_family = AF_INET6 then + Result := htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + begin + _Addr := Addr^; + FreeAddrInfo(_Addr); + end; + end; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + Hints: AddrInfo; + Addr: PAddrInfo; + _Addr: AddrInfo; + r: integer; + host, serv: TBytes; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: UINT32; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := inet_addr(MarshaledAString(TMarshal.AsAnsi(IP))); + if IPn <> UINT32(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := string(RemoteHost^.h_name); + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), nil, Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr^, Addr^.ai_addrlen, + @host[0], hostlen, @serv[0], servlen, + NI_NUMERICSERV); + if r = 0 then + Result := StringOf(host); + SetLength(host, 0); + SetLength(serv, 0); + end; + finally + if Assigned(Addr) then + begin + _Addr := Addr^; + FreeAddrInfo(_Addr); + end; + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + SockEnhancedApi := True; + SockWship6Api := False; + Signal(SIGPIPE, TSignalHandler(SIG_IGN)); + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} \ No newline at end of file diff --git a/sswin32.inc b/sswin32.inc new file mode 100644 index 0000000..a63386e --- /dev/null +++ b/sswin32.inc @@ -0,0 +1,1661 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.003.001 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Win32/64 definition include | +|==============================================================================| +| Copyright (c)1999-2012, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +//{$DEFINE WINSOCK1} +{Note about define WINSOCK1: +If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install update. +} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT '/* EDE 2003-02-19 */' *) + (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) + (*$HPPEMIT '#undef h_addr' *) + (*$HPPEMIT '#undef IOCPARM_MASK' *) + (*$HPPEMIT '#undef FD_SETSIZE' *) + (*$HPPEMIT '#undef IOC_VOID' *) + (*$HPPEMIT '#undef IOC_OUT' *) + (*$HPPEMIT '#undef IOC_IN' *) + (*$HPPEMIT '#undef IOC_INOUT' *) + (*$HPPEMIT '#undef FIONREAD' *) + (*$HPPEMIT '#undef FIONBIO' *) + (*$HPPEMIT '#undef FIOASYNC' *) + (*$HPPEMIT '#undef IPPROTO_IP' *) + (*$HPPEMIT '#undef IPPROTO_ICMP' *) + (*$HPPEMIT '#undef IPPROTO_IGMP' *) + (*$HPPEMIT '#undef IPPROTO_TCP' *) + (*$HPPEMIT '#undef IPPROTO_UDP' *) + (*$HPPEMIT '#undef IPPROTO_RAW' *) + (*$HPPEMIT '#undef IPPROTO_MAX' *) + (*$HPPEMIT '#undef INADDR_ANY' *) + (*$HPPEMIT '#undef INADDR_LOOPBACK' *) + (*$HPPEMIT '#undef INADDR_BROADCAST' *) + (*$HPPEMIT '#undef INADDR_NONE' *) + (*$HPPEMIT '#undef INVALID_SOCKET' *) + (*$HPPEMIT '#undef SOCKET_ERROR' *) + (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) + (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) + (*$HPPEMIT '#undef IP_OPTIONS' *) + (*$HPPEMIT '#undef IP_TOS' *) + (*$HPPEMIT '#undef IP_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_IF' *) + (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) + (*$HPPEMIT '#undef SOL_SOCKET' *) + (*$HPPEMIT '#undef SO_DEBUG' *) + (*$HPPEMIT '#undef SO_ACCEPTCONN' *) + (*$HPPEMIT '#undef SO_REUSEADDR' *) + (*$HPPEMIT '#undef SO_KEEPALIVE' *) + (*$HPPEMIT '#undef SO_DONTROUTE' *) + (*$HPPEMIT '#undef SO_BROADCAST' *) + (*$HPPEMIT '#undef SO_USELOOPBACK' *) + (*$HPPEMIT '#undef SO_LINGER' *) + (*$HPPEMIT '#undef SO_OOBINLINE' *) + (*$HPPEMIT '#undef SO_DONTLINGER' *) + (*$HPPEMIT '#undef SO_SNDBUF' *) + (*$HPPEMIT '#undef SO_RCVBUF' *) + (*$HPPEMIT '#undef SO_SNDLOWAT' *) + (*$HPPEMIT '#undef SO_RCVLOWAT' *) + (*$HPPEMIT '#undef SO_SNDTIMEO' *) + (*$HPPEMIT '#undef SO_RCVTIMEO' *) + (*$HPPEMIT '#undef SO_ERROR' *) + (*$HPPEMIT '#undef SO_OPENTYPE' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) + (*$HPPEMIT '#undef SO_MAXDG' *) + (*$HPPEMIT '#undef SO_MAXPATHDG' *) + (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) + (*$HPPEMIT '#undef SO_CONNECT_TIME' *) + (*$HPPEMIT '#undef SO_TYPE' *) + (*$HPPEMIT '#undef SOCK_STREAM' *) + (*$HPPEMIT '#undef SOCK_DGRAM' *) + (*$HPPEMIT '#undef SOCK_RAW' *) + (*$HPPEMIT '#undef SOCK_RDM' *) + (*$HPPEMIT '#undef SOCK_SEQPACKET' *) + (*$HPPEMIT '#undef TCP_NODELAY' *) + (*$HPPEMIT '#undef AF_UNSPEC' *) + (*$HPPEMIT '#undef SOMAXCONN' *) + (*$HPPEMIT '#undef AF_INET' *) + (*$HPPEMIT '#undef AF_MAX' *) + (*$HPPEMIT '#undef PF_UNSPEC' *) + (*$HPPEMIT '#undef PF_INET' *) + (*$HPPEMIT '#undef PF_MAX' *) + (*$HPPEMIT '#undef MSG_OOB' *) + (*$HPPEMIT '#undef MSG_PEEK' *) + (*$HPPEMIT '#undef WSABASEERR' *) + (*$HPPEMIT '#undef WSAEINTR' *) + (*$HPPEMIT '#undef WSAEBADF' *) + (*$HPPEMIT '#undef WSAEACCES' *) + (*$HPPEMIT '#undef WSAEFAULT' *) + (*$HPPEMIT '#undef WSAEINVAL' *) + (*$HPPEMIT '#undef WSAEMFILE' *) + (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) + (*$HPPEMIT '#undef WSAEINPROGRESS' *) + (*$HPPEMIT '#undef WSAEALREADY' *) + (*$HPPEMIT '#undef WSAENOTSOCK' *) + (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) + (*$HPPEMIT '#undef WSAEMSGSIZE' *) + (*$HPPEMIT '#undef WSAEPROTOTYPE' *) + (*$HPPEMIT '#undef WSAENOPROTOOPT' *) + (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) + (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) + (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEADDRINUSE' *) + (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) + (*$HPPEMIT '#undef WSAENETDOWN' *) + (*$HPPEMIT '#undef WSAENETUNREACH' *) + (*$HPPEMIT '#undef WSAENETRESET' *) + (*$HPPEMIT '#undef WSAECONNABORTED' *) + (*$HPPEMIT '#undef WSAECONNRESET' *) + (*$HPPEMIT '#undef WSAENOBUFS' *) + (*$HPPEMIT '#undef WSAEISCONN' *) + (*$HPPEMIT '#undef WSAENOTCONN' *) + (*$HPPEMIT '#undef WSAESHUTDOWN' *) + (*$HPPEMIT '#undef WSAETOOMANYREFS' *) + (*$HPPEMIT '#undef WSAETIMEDOUT' *) + (*$HPPEMIT '#undef WSAECONNREFUSED' *) + (*$HPPEMIT '#undef WSAELOOP' *) + (*$HPPEMIT '#undef WSAENAMETOOLONG' *) + (*$HPPEMIT '#undef WSAEHOSTDOWN' *) + (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) + (*$HPPEMIT '#undef WSAENOTEMPTY' *) + (*$HPPEMIT '#undef WSAEPROCLIM' *) + (*$HPPEMIT '#undef WSAEUSERS' *) + (*$HPPEMIT '#undef WSAEDQUOT' *) + (*$HPPEMIT '#undef WSAESTALE' *) + (*$HPPEMIT '#undef WSAEREMOTE' *) + (*$HPPEMIT '#undef WSASYSNOTREADY' *) + (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) + (*$HPPEMIT '#undef WSANOTINITIALISED' *) + (*$HPPEMIT '#undef WSAEDISCON' *) + (*$HPPEMIT '#undef WSAENOMORE' *) + (*$HPPEMIT '#undef WSAECANCELLED' *) + (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) + (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) + (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) + (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) + (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSA_E_NO_MORE' *) + (*$HPPEMIT '#undef WSA_E_CANCELLED' *) + (*$HPPEMIT '#undef WSAEREFUSED' *) + (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) + (*$HPPEMIT '#undef HOST_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATRY_AGAIN' *) + (*$HPPEMIT '#undef TRY_AGAIN' *) + (*$HPPEMIT '#undef WSANO_RECOVERY' *) + (*$HPPEMIT '#undef NO_RECOVERY' *) + (*$HPPEMIT '#undef WSANO_DATA' *) + (*$HPPEMIT '#undef NO_DATA' *) + (*$HPPEMIT '#undef WSANO_ADDRESS' *) + (*$HPPEMIT '#undef ENAMETOOLONG' *) + (*$HPPEMIT '#undef ENOTEMPTY' *) + (*$HPPEMIT '#undef FD_CLR' *) + (*$HPPEMIT '#undef FD_ISSET' *) + (*$HPPEMIT '#undef FD_SET' *) + (*$HPPEMIT '#undef FD_ZERO' *) + (*$HPPEMIT '#undef NO_ADDRESS' *) + (*$HPPEMIT '#undef ADDR_ANY' *) + (*$HPPEMIT '#undef SO_GROUP_ID' *) + (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) + (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) + (*$HPPEMIT '#undef PVD_CONFIG' *) + (*$HPPEMIT '#undef AF_INET6' *) + (*$HPPEMIT '#undef PF_INET6' *) + (*$HPPEMIT '#undef NI_MAXHOST' *) + (*$HPPEMIT '#undef NI_MAXSERV' *) + (*$HPPEMIT '#undef NI_NOFQDN' *) + (*$HPPEMIT '#undef NI_NUMERICHOST' *) + (*$HPPEMIT '#undef NI_NAMEREQD' *) + (*$HPPEMIT '#undef NI_NUMERICSERV' *) + (*$HPPEMIT '#undef NI_DGRAM' *) + (*$HPPEMIT '#undef AI_PASSIVE' *) + (*$HPPEMIT '#undef AI_CANONNAME' *) + (*$HPPEMIT '#undef AI_NUMERICHOST' *) + (*$HPPEMIT '#undef EWOULDBLOCK' *) + (*$HPPEMIT '#undef EINPROGRESS' *) + (*$HPPEMIT '#undef EALREADY' *) + (*$HPPEMIT '#undef ENOTSOCK' *) + (*$HPPEMIT '#undef EDESTADDRREQ' *) + (*$HPPEMIT '#undef EMSGSIZE' *) + (*$HPPEMIT '#undef EPROTOTYPE' *) + (*$HPPEMIT '#undef ENOPROTOOPT' *) + (*$HPPEMIT '#undef EPROTONOSUPPORT' *) + (*$HPPEMIT '#undef EOPNOTSUPP' *) + (*$HPPEMIT '#undef EAFNOSUPPORT' *) + (*$HPPEMIT '#undef EADDRINUSE' *) + (*$HPPEMIT '#undef EADDRNOTAVAIL' *) + (*$HPPEMIT '#undef ENETDOWN' *) + (*$HPPEMIT '#undef ENETUNREACH' *) + (*$HPPEMIT '#undef ENETRESET' *) + (*$HPPEMIT '#undef ECONNABORTED' *) + (*$HPPEMIT '#undef ECONNRESET' *) + (*$HPPEMIT '#undef ENOBUFS' *) + (*$HPPEMIT '#undef EISCONN' *) + (*$HPPEMIT '#undef ENOTCONN' *) + (*$HPPEMIT '#undef ETIMEDOUT' *) + (*$HPPEMIT '#undef ECONNREFUSED' *) + (*$HPPEMIT '#undef ELOOP' *) + (*$HPPEMIT '#undef EHOSTUNREACH' *) +{$ENDIF} + +{$IFDEF FPC} + {$IFDEF WIN32} + {$ALIGN OFF} + {$ELSE} + {$PACKRECORDS C} + {$ENDIF} +{$ELSE} + {$IFDEF WIN64} + {$ALIGN ON} + {$MINENUMSIZE 4} + {$ELSE} + {$MINENUMSIZE 4} + {$ALIGN OFF} + {$ENDIF} +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, Classes, + Windows; + +function InitSocketInterface(stack: String): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; +{$IFDEF FPC} + TSocket = ptruint; +{$ELSE} + {$IFDEF WIN64} + TSocket = UINT_PTR; + {$ELSE} + TSocket = u_int; + {$ENDIF} +{$ENDIF} + TAddrFamily = integer; + + TMemory = pointer; + +const + {$IFDEF WINCE} + DLLStackName = 'ws2.dll'; + {$ELSE} + {$IFDEF WINSOCK1} + DLLStackName = 'wsock32.dll'; + {$ELSE} + DLLStackName = 'ws2_32.dll'; + {$ENDIF} + {$ENDIF} + DLLwship6 = 'wship6.dll'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + + +const + FD_SETSIZE = 64; +type + PFDSet = ^TFDSet; + TFDSet = record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + + PInAddr = ^TInAddr; + TInAddr = record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + 1: (sa_family: u_short; + sa_data: array[0..13] of byte) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: integer; + end; + + PHostEnt = ^THostEnt; + THostEnt = record + h_name: PAnsiChar; + h_aliases: ^PAnsiChar; + h_addrtype: Smallint; + h_length: Smallint; + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; + n_addrtype: Smallint; + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; +{$ifdef WIN64} + s_proto: PAnsiChar; + s_port: Smallint; +{$else} + s_port: Smallint; + s_proto: PAnsiChar; +{$endif} + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PAnsiChar; + p_aliases: ^PAnsichar; + p_proto: Smallint; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$IFDEF WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$ENDIF} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PAnsiChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = record + l_onoff: u_short; + l_linger: u_short; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = record + wVersion: Word; + wHighVersion: Word; +{$ifdef win64} + iMaxSockets : Word; + iMaxUdpDg : Word; + lpVendorInfo : PAnsiChar; + szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; +{$else} + szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PAnsiChar; +{$endif} + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + stdcall; + TWSACleanup = function: Integer; + stdcall; + TWSAGetLastError = function: Integer; + stdcall; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; + stdcall; + TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; + stdcall; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; + stdcall; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + stdcall; + TGetHostByName = function(name: PAnsiChar): PHostEnt; + stdcall; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + stdcall; + TGetHostName = function(name: PAnsiChar; len: Integer): Integer; + stdcall; + TShutdown = function(s: TSocket; how: Integer): Integer; + stdcall; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; + stdcall; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; + stdcall; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + stdcall; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + stdcall; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + stdcall; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + stdcall; + Tntohs = function(netshort: u_short): u_short; + stdcall; + Tntohl = function(netlong: u_long): u_long; + stdcall; + TListen = function(s: TSocket; backlog: Integer): Integer; + stdcall; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; + stdcall; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; + stdcall; + TInet_addr = function(cp: PAnsiChar): u_long; + stdcall; + Thtons = function(hostshort: u_short): u_short; + stdcall; + Thtonl = function(hostlong: u_long): u_long; + stdcall; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + stdcall; + TCloseSocket = function(s: TSocket): Integer; + stdcall; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + stdcall; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + stdcall; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + stdcall; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + stdcall; + + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + stdcall; + TFreeAddrInfo = procedure(ai: PAddrInfo); + stdcall; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; + stdcall; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + stdcall; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + stdcall; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: AnsiString; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): AnsiString; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType: integer): Word; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + I: Integer; +begin + I := 0; + while I < FDSet.fd_count do + begin + if FDSet.fd_array[I] = Socket then + begin + while I < FDSet.fd_count - 1 do + begin + FDSet.fd_array[I] := FDSet.fd_array[I + 1]; + Inc(I); + end; + Dec(FDSet.fd_count); + Break; + end; + Inc(I); + end; +end; + +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +begin + Result := __WSAFDIsSet(Socket, FDSet); +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin + if FDSet.fd_count < FD_SETSIZE then + begin + FDSet.fd_array[FDSet.fd_count] := Socket; + Inc(FDSet.fd_count); + end; +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: AnsiString; +var + s: AnsiString; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pAnsichar(s), Length(s) - 1); + Result := PAnsichar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family, + SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PAnsiChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): AnsiString; +var + p: PAnsiChar; + host, serv: AnsiString; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, + PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, + SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: String; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PAnsiChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(string(Name)); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PAnsiChar(host); + IPList.Add(string(host)); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType: + integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(string(Port), 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType: + integer): AnsiString; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PAnsiChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: String): Boolean; +begin + Result := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); + WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); + WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); + WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); + ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); + ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); + ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); + ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); + ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); + GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); + Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); + Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); + Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); + Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); + Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); + Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); + Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); + ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); + ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); + Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); + ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); + ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); + SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); + GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); + GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); + GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); + GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); + GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); + GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); + ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo'))); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + if not SockEnhancedApi then + begin + LibWship6Handle := LoadLibrary(PChar(DLLWship6)); + if LibWship6Handle <> 0 then + begin + GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo'))); + SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + end; + end; +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; \ No newline at end of file diff --git a/synabyte.pas b/synabyte.pas new file mode 100644 index 0000000..43d03b5 --- /dev/null +++ b/synabyte.pas @@ -0,0 +1,368 @@ +{==============================================================================| +| Project : Ararat Synapse | 003.012.008 | +|==============================================================================| +| Content: buffer wrapper layer +|==============================================================================| +| Copyright (c)1999-2014, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): Radek Cervinka, delphi.cz | +| Ondrej Pokorny, kluug.net +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(NextGen and Unicode buffer layer)} + +unit synabyte; +{$i jedi.inc} + +interface +uses + sysutils; +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} +type +{$IFDEF UNICODE} + TSynaByte = byte; + TSynaBytes = record + private + FBytes: TBytes; + FRefCheck: string; + + function GetChars(const Index: NativeInt): Char; + procedure SetChars(const Index: NativeInt; const Value: Char); + function AGetLength: NativeInt; + procedure ASetLength(const Value: NativeInt); + + procedure UpdateTerminator; + procedure CheckCow; + procedure Unique; + public + class operator Implicit(const V1: String): TSynaBytes; + class operator Implicit(const V1: RawByteString): TSynaBytes; + class operator Implicit(const V1: TSynaBytes): String; + class operator Implicit(const V1: Char): TSynaBytes; + class operator Explicit(const V1: TBytes): TSynaBytes; + + + class operator Add(const V1, V2: TSynaBytes): TSynaBytes; + + class operator Equal(const V1, V2: TSynaBytes): Boolean; + class operator NotEqual(const V1, V2: TSynaBytes): Boolean; + + function Clone: TSynaBytes; + procedure Delete(Start, Count: Integer); + function Data: Pointer; + + + property Chars[const Index: NativeInt]: Char read GetChars write SetChars; default; + property Length: NativeInt read AGetLength write ASetLength; + property Bytes:TBytes read FBytes; + end; + +// procedure SetLength(var s: TSynaBytes; Count:Integer); overload; + +{$ELSE} + TSynaBytes = AnsiString; + TSynaByte = AnsiChar; +{$ENDIF} + +{$IFNDEF DELPHI12_UP} + TBytes = Array of Byte; + + function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean; +{$ENDIF} + + function StringOf(const bytes: TSynaBytes):string; overload; + function StringOf(const bytes: TBytes):string; overload; + function StringOf(const bytes: PByte): String; overload; + + procedure DeleteInternal (var s: TSynaBytes; Start, Count: Integer); + +implementation + +{$IFDEF UNICODE} + +function IsBytesEquals(const Bytes1, Bytes2: TBytes; const Len1, Len2: NativeInt): Boolean; +var + i: NativeInt; +begin + if Len1 <> Len2 then + Exit(False); + + for i := 0 to Len1 - 1 do + if Bytes1[i] <> Bytes2[i] then + Exit(False); + + Result := True; +end; + +class operator TSynaBytes.Implicit(const V1: String): TSynaBytes; +begin + Result.FBytes := TEncoding.Default.GetBytes(V1); + Result.Length := System.Length(Result.FBytes); +end; + +class operator TSynaBytes.Add(const V1, V2: TSynaBytes): TSynaBytes; +begin + Result.Length := V1.Length + V2.Length; + if V1.Length > 0 then + Move(V1.FBytes[0], Result.FBytes[0], V1.Length); + if V2.Length > 0 then + Move(V2.FBytes[0], Result.FBytes[V1.Length], V2.Length); +end; + +procedure TSynaBytes.CheckCow; + function RefCount: Integer; + var + xStrPtr: ^Integer; + begin + //get reference count of FStrBuffer, correct results on 32bit, 64bit and also mobile + xStrPtr := Pointer(PChar(FRefCheck)); + Dec(xStrPtr, 2); + Result := xStrPtr^; + end; + +begin + if RefCount <> 1 then + begin + Unique; + end; + FRefCheck := '!'; +end; + +function TSynaBytes.Clone: TSynaBytes; +begin + Result.Length := Self.Length; + Move(FBytes[0], Result.FBytes[0], Self.Length); +end; + +function TSynaBytes.Data: Pointer; +begin + Result := @FBytes[0]; +end; + +// zero based +procedure TSynaBytes.Delete(Start, Count: Integer); +begin + if Count <= 0 then + Exit; + CheckCow; + if Length - Count <= 0 then + begin + Length := 0; + Exit; + end; + if (Start >= 0) then + begin + Move(FBytes[Start + Count], FBytes[Start], Length - Count); + Length := Length - Count; + end; +end; + +class operator TSynaBytes.Equal(const V1, V2: TSynaBytes): Boolean; +begin + Result := IsBytesEquals(V1.FBytes, V2.FBytes, V1.Length, V2.Length); +end; + +class operator TSynaBytes.Explicit(const V1: TBytes): TSynaBytes; +begin + Result.FBytes := Copy(V1); + Result.Length := System.Length(V1); +end; + +function TSynaBytes.GetChars(const Index: NativeInt): Char; +begin + Result := Char(FBytes[Index]); +end; + +function TSynaBytes.AGetLength: NativeInt; +begin + Result := System.Length(FBytes); + + if Result > 0 then + Result := Result - 1; // Null Terminator +end; + +class operator TSynaBytes.Implicit(const V1: Char): TSynaBytes; +begin + Result.FBytes := TEncoding.Default.GetBytes(V1); + Result.Length := System.Length(Result.FBytes); +end; + +class operator TSynaBytes.Implicit(const V1: RawByteString): TSynaBytes; +var + I: Integer; +begin + Result.Length := System.Length(V1); + for I := 1 to System.Length(V1) do + Result.FBytes[I-1] := Byte(V1[I]);//warning: null-terminated strings! +end; + +class operator TSynaBytes.Implicit(const V1: TSynaBytes): String; +var + //I: Integer; + //C: PWord; + S: RawByteString; +begin + SetLength(Result, V1.Length); + if V1.Length > 0 then + begin + //ïåðåïèñàë, 4873 + SetLength(s, V1.Length); + Move(V1.FBytes[0], s[1], V1.Length); + Result := string(s); + {C := PWord(PWideChar(Result)); + for I := 0 to V1.Length-1 do + begin + C^ := V1.FBytes[I]; + Inc(C); + end;} + end; +end; + +class operator TSynaBytes.NotEqual(const V1, V2: TSynaBytes): Boolean; +begin + Result := not IsBytesEquals(V1.FBytes, V2.FBytes, V1.Length, V2.Length); +end; + +procedure TSynaBytes.SetChars(const Index: NativeInt; const Value: Char); +begin + CheckCow; + FBytes[Index] := Byte(Value); +end; + +procedure TSynaBytes.Unique; +var + b:TBytes; +begin + SetLength(b, Self.Length + 1); + Move(FBytes[0], b[0], Self.Length); + FBytes := b; +end; + +procedure TSynaBytes.UpdateTerminator; +begin + if System.Length(FBytes) > 0 then + FBytes[System.Length(FBytes) - 1] := 0; +end; + +procedure TSynaBytes.ASetLength(const Value: NativeInt); +begin + System.SetLength(FBytes, Value + 1); // +1, null terminator + Self.UpdateTerminator(); +end; +{$ENDIF} + +function StringOf(const bytes: TSynaBytes):string; +begin + Result := bytes; +end; + +function StringOf(const bytes: TBytes):string; +{$IFDEF UNICODE} +var + I: Integer; + C: PWord; +begin + SetLength(Result, Length(bytes)); + if Length(bytes) > 0 then + begin + C := PWord(PWideChar(Result)); + for I := 0 to Length(bytes)-1 do + begin + C^ := bytes[I]; + Inc(C); + end; + end; +{$ELSE} +begin + SetLength(Result, Length(bytes)); + if Length(bytes) > 0 then + Move(bytes[0], result[1], Length(bytes)); +{$ENDIF} +end; + +function StringOf(const bytes: PByte):string; +var + count: Integer; + buf: PByte; +{$IFDEF UNICODE} + I: Integer; + C: PWord; +{$ENDIF} +begin + Count := 0; + buf := bytes; + while buf^<>0 do + begin + inc(count); + inc(buf); + end; +{$IFDEF UNICODE} + SetLength(Result, count); + if count > 0 then + begin + C := PWord(PWideChar(Result)); + for I := 0 to count-1 do + begin + C^ := bytes[I]; + Inc(C); + end; + end; +{$ELSE} + SetLength(Result, count); + Move(bytes^, result[1], count); +{$ENDIF} +end; + +procedure DeleteInternal (var s: TSynaBytes; Start, Count: Integer); +begin +{$IFDEF UNICODE} + s.Delete(Start - 1, Count); +{$ELSE} + Delete(s, Start , Count); +{$ENDIF} +end; + +{$IFNDEF DELPHI12_UP} +function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean; +begin + Result := C in CharSet; +end; +{$ENDIF} + +end. diff --git a/synachar.pas b/synachar.pas new file mode 100644 index 0000000..f35b6f1 --- /dev/null +++ b/synachar.pas @@ -0,0 +1,2041 @@ +{==============================================================================| +| Project : Ararat Synapse | 005.002.004 | +|==============================================================================| +| Content: Charset conversion support | +|==============================================================================| +| Copyright (c)1999-2015, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2015. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(Charset conversion support) +This unit contains a routines for lot of charset conversions. + +It using built-in conversion tables or external Iconv library. Iconv is used + when needed conversion is known by Iconv library. When Iconv library is not + found or Iconv not know requested conversion, then are internal routines used + for conversion. (You can disable Iconv support from your program too!) + +Internal routines knows all major charsets for Europe or America. For East-Asian + charsets you must use Iconv library! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synachar; + +interface + +uses +{$IFNDEF MSWINDOWS} + {$IFNDEF FPC} + Libc, + {$ENDIF} +{$ELSE} + Windows, +{$ENDIF} +{$IFDEF ULTIBO} + Locale, +{$ENDIF} + SysUtils, + synautil, synacode, synaicnv; + +type + {:Type with all supported charsets.} + TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13, + ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255, + CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7, + UTF_7mod, UCS_2LE, UCS_4LE, + //next is supported by Iconv only... + UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, + CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, + MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, + KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, + JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, + SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, + GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, + EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, + CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125); + + {:Set of any charsets.} + TMimeSetChar = set of TMimeChar; + +const + {:Set of charsets supported by Iconv library only.} + IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE, + C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE, + MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8, + NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133, + TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212, + GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932, + ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030, + ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR, + CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858, + CP860, CP861, CP863, CP864, CP865, CP869, CP1125]; + + {:Set of charsets supported by internal routines only.} + NoIconvChars: set of TMimeChar = [CP895, UTF_7mod]; + + {:null character replace table. (Usable for disable charater replacing.)} + Replace_None: array[0..0] of Word = + (0); + + {:Character replace table for remove Czech diakritics.} + Replace_Czech: array[0..59] of Word = + ( + $00E1, $0061, + $010D, $0063, + $010F, $0064, + $010E, $0044, + $00E9, $0065, + $011B, $0065, + $00ED, $0069, + $0148, $006E, + $00F3, $006F, + $0159, $0072, + $0161, $0073, + $0165, $0074, + $00FA, $0075, + $016F, $0075, + $00FD, $0079, + $017E, $007A, + $00C1, $0041, + $010C, $0043, + $00C9, $0045, + $011A, $0045, + $00CD, $0049, + $0147, $004E, + $00D3, $004F, + $0158, $0052, + $0160, $0053, + $0164, $0054, + $00DA, $0055, + $016E, $0055, + $00DD, $0059, + $017D, $005A + ); + +var + {:By this you can generally disable/enable Iconv support.} + DisableIconv: Boolean = False; + + {:Default set of charsets for @link(IdealCharsetCoding) function.} + IdealCharsets: TMimeSetChar = + [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, + KOI8_R, KOI8_U + {$IFNDEF CIL} //error URW778 ??? :-O + , GB2312, EUC_KR, ISO_2022_JP, EUC_TW + {$ENDIF} + ]; + +{==============================================================================} +{:Convert Value from one charset to another. See: @link(CharsetConversionEx)} +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. +see: @link(Replace_None) and @link(Replace_Czech)} +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. + This funtion is similar to @link(CharsetConversionEx), but you can disable + transliteration of unconvertible characters.} +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; + +{:Returns charset used by operating system.} +function GetCurCP: TMimeChar; + +{:Returns charset used by operating system as OEM charset. (in Windows DOS box, + for example)} +function GetCurOEMCP: TMimeChar; + +{:Converting string with charset name to TMimeChar.} +function GetCPFromID(Value: AnsiString): TMimeChar; + +{:Converting TMimeChar to string with name of charset.} +function GetIDFromCP(Value: TMimeChar): AnsiString; + +{:return @true when value need to be converted. (It is not 7-bit ASCII)} +function NeedCharsetConversion(const Value: AnsiString): Boolean; + +{:Finding best target charset from set of TMimeChars with minimal count of + unconvertible characters.} +function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar; + CharTo: TMimeSetChar): TMimeChar; + +{:Return BOM (Byte Order Mark) for given unicode charset.} +function GetBOM(Value: TMimeChar): AnsiString; + +{:Convert binary string with unicode content to WideString.} +function StringToWide(const Value: AnsiString): WideString; + +{:Convert WideString to binary string with unicode content.} +function WideToString(const Value: WideString): AnsiString; + +function GetIconvIDFromCP(Value: TMimeChar): AnsiString; +function GetCPFromIconvID(Value: AnsiString): TMimeChar; + +{==============================================================================} +implementation + +//character transcoding tables X to UCS-2 +{ +//dummy table +$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, +$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, +$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, +$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, +$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, +$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, +$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, +$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, +$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, +$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, +$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, +$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, +$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, +$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, +$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, +$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF +} + +const + +{Latin-1 + Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, + Irish, Italian, Norwegian, Portuguese, Spanish and Swedish. +} + CharISO_8859_1: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Latin-2 + Albanian, Czech, English, German, Hungarian, Polish, Rumanian, + Serbo-Croatian, Slovak, Slovene and Swedish. +} + CharISO_8859_2: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, + $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, + $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, + $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, + $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, + $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, + $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, + $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, + $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 + ); + +{Latin-3 + Afrikaans, Catalan, English, Esperanto, French, Galician, + German, Italian, Maltese and Turkish. +} + CharISO_8859_3: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7, + $00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B, + $00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7, + $00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C, + $00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7, + $011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF, + $00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7, + $011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9 + ); + +{Latin-4 + Danish, English, Estonian, Finnish, German, Greenlandic, + Lappish, Latvian, Lithuanian, Norwegian and Swedish. +} + CharISO_8859_4: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7, + $00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF, + $00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7, + $00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B, + $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, + $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A, + $0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7, + $00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF, + $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, + $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B, + $0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7, + $00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9 + ); + +{CYRILLIC + Bulgarian, Bielorussian, English, Macedonian, Russian, + Serbo-Croatian and Ukrainian. +} + CharISO_8859_5: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407, + $0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F, + $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, + $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, + $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, + $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, + $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, + $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, + $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, + $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F, + $2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457, + $0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F + ); + +{ARABIC +} + CharISO_8859_6: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F, + $FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627, + $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, + $0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637, + $0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647, + $0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F, + $0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD + ); + +{GREEK +} + CharISO_8859_7: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7, + $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015, + $00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7, + $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, + $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, + $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, + $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, + $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, + $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, + $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, + $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, + $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD + ); + +{HEBREW +} + CharISO_8859_8: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017, + $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, + $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, + $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, + $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD + ); + +{Latin-5 + English, Finnish, French, German, Irish, Italian, Norwegian, + Portuguese, Spanish, Swedish and Turkish. +} + CharISO_8859_9: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, + $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, + $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, + $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF + ); + +{Latin-6 + Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic, + Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish. +} + CharISO_8859_10: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7, + $013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A, + $00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7, + $013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B, + $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, + $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF, + $00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168, + $00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, + $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF, + $00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169, + $00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138 + ); + + CharISO_8859_13: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7, + $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, + $00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7, + $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, + $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, + $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, + $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, + $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, + $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, + $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, + $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, + $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019 + ); + + CharISO_8859_14: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7, + $1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178, + $1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56, + $1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF + ); + + CharISO_8859_15: array[128..255] of Word = + ( + $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, + $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, + $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, + $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, + $00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7, + $0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7, + $017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Eastern European +} + CharCP_1250: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, + $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A, + $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, + $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, + $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7, + $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C, + $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, + $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, + $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, + $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, + $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, + $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, + $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, + $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 + ); + +{Cyrillic +} + CharCP_1251: array[128..255] of Word = + ( + $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021, + $20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F, + $0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F, + $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7, + $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407, + $00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7, + $0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457, + $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, + $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, + $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, + $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, + $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, + $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, + $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, + $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F + ); + +{Latin-1 (US, Western Europe) +} + CharCP_1252: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF + ); + +{Greek +} + CharCP_1253: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, + $00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015, + $00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7, + $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, + $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, + $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, + $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, + $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, + $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, + $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, + $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, + $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD + ); + +{Turkish +} + CharCP_1254: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, + $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, + $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF + ); + +{Hebrew +} + CharCP_1255: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, + $00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7, + $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF, + $05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7, + $05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF, + $05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3, + $05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, + $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, + $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, + $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, + $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD + ); + +{Arabic +} + CharCP_1256: array[128..255] of Word = + ( + $20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688, + $06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA, + $00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F, + $06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627, + $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, + $0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7, + $0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643, + $00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7, + $00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF, + $064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7, + $0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2 + ); + +{Baltic +} + CharCP_1257: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, + $FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD, + $00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7, + $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, + $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, + $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, + $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, + $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, + $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, + $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, + $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, + $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9 + ); + +{Vietnamese +} + CharCP_1258: array[128..255] of Word = + ( + $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, + $02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD, + $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, + $02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178, + $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, + $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, + $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, + $00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7, + $00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF, + $0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7, + $00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF, + $00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7, + $00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF, + $0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF + ); + +{Cyrillic +} + CharKOI8_R: array[128..255] of Word = + ( + $2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524, + $252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590, + $2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248, + $2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7, + $2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556, + $2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E, + $255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565, + $2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9, + $044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433, + $0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E, + $043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432, + $044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A, + $042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413, + $0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E, + $041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412, + $042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A + ); + +{Czech (Kamenicky) +} + CharCP_895: array[128..255] of Word = + ( + $010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D, + $011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1, + $00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA, + $00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165, + $00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4, + $0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB, + $2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556, + $2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510, + $2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F, + $255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567, + $2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B, + $256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580, + $03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4, + $03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229, + $2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248, + $2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0 + ); + +{Eastern European +} + CharCP_852: array[128..255] of Word = + ( + $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7, + $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106, + $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A, + $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D, + $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E, + $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB, + $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A, + $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510, + $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103, + $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4, + $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE, + $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580, + $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161, + $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4, + $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8, + $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0 + ); + +{==============================================================================} +type + TIconvChar = record + Charset: TMimeChar; + CharName: string; + end; + TIconvArr = array [0..112] of TIconvChar; + +const + NotFoundChar = '_'; + +var + SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod]; + SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8]; + SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE]; + + IconvArr: TIconvArr; + +{==============================================================================} +function FindIconvID(const Value, Charname: string): Boolean; +var + s: string; +begin + Result := True; + //exact match + if Value = Charname then + Exit; + //Value is on begin of charname + s := Value + ' '; + if s = Copy(Charname, 1, Length(s)) then + Exit; + //Value is on end of charname + s := ' ' + Value; + if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then + Exit; + //value is somewhere inside charname + if Pos( s + ' ', Charname) > 0 then + Exit; + Result := False; +end; + +function GetCPFromIconvID(Value: AnsiString): TMimeChar; +var + n: integer; +begin + Result := ISO_8859_1; + Value := UpperCase(Value); + for n := 0 to High(IconvArr) do + if FindIconvID(Value, IconvArr[n].Charname) then + begin + Result := IconvArr[n].Charset; + Break; + end; +end; + +{==============================================================================} +function GetIconvIDFromCP(Value: TMimeChar): AnsiString; +var + n: integer; +begin + Result := 'ISO-8859-1'; + for n := 0 to High(IconvArr) do + if IconvArr[n].Charset = Value then + begin + Result := Separateleft(IconvArr[n].Charname, ' '); + Break; + end; +end; + +{==============================================================================} +function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word; +var + n: integer; +begin + if High(TransformTable) <> 0 then + for n := 0 to High(TransformTable) do + if not odd(n) then + if TransformTable[n] = Value then + begin + Value := TransformTable[n+1]; + break; + end; + Result := Value; +end; + +{==============================================================================} +procedure CopyArray(const SourceTable: array of Word; + var TargetTable: array of Word); +var + n: Integer; +begin + for n := 0 to 127 do + TargetTable[n] := SourceTable[n]; +end; + +{==============================================================================} +procedure GetArray(CharSet: TMimeChar; var Result: array of Word); +begin + case CharSet of + ISO_8859_2: + CopyArray(CharISO_8859_2, Result); + ISO_8859_3: + CopyArray(CharISO_8859_3, Result); + ISO_8859_4: + CopyArray(CharISO_8859_4, Result); + ISO_8859_5: + CopyArray(CharISO_8859_5, Result); + ISO_8859_6: + CopyArray(CharISO_8859_6, Result); + ISO_8859_7: + CopyArray(CharISO_8859_7, Result); + ISO_8859_8: + CopyArray(CharISO_8859_8, Result); + ISO_8859_9: + CopyArray(CharISO_8859_9, Result); + ISO_8859_10: + CopyArray(CharISO_8859_10, Result); + ISO_8859_13: + CopyArray(CharISO_8859_13, Result); + ISO_8859_14: + CopyArray(CharISO_8859_14, Result); + ISO_8859_15: + CopyArray(CharISO_8859_15, Result); + CP1250: + CopyArray(CharCP_1250, Result); + CP1251: + CopyArray(CharCP_1251, Result); + CP1252: + CopyArray(CharCP_1252, Result); + CP1253: + CopyArray(CharCP_1253, Result); + CP1254: + CopyArray(CharCP_1254, Result); + CP1255: + CopyArray(CharCP_1255, Result); + CP1256: + CopyArray(CharCP_1256, Result); + CP1257: + CopyArray(CharCP_1257, Result); + CP1258: + CopyArray(CharCP_1258, Result); + KOI8_R: + CopyArray(CharKOI8_R, Result); + CP895: + CopyArray(CharCP_895, Result); + CP852: + CopyArray(CharCP_852, Result); + else + CopyArray(CharISO_8859_1, Result); + end; +end; + +{==============================================================================} +procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; + var b1, b2, b3, b4: Byte; le: boolean); +Begin + b1 := 0; + b2 := 0; + b3 := 0; + b4 := 0; + if Index < 0 then + Index := 1; + if mb > 4 then + mb := 1; + if (Index + mb - 1) <= Length(Value) then + begin + if le then + Case mb Of + 1: + b1 := Ord(Value[Index]); + 2: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + End; + 3: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + End; + 4: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + b4 := Ord(Value[Index + 3]); + End; + end + else + Case mb Of + 1: + b1 := Ord(Value[Index]); + 2: + Begin + b2 := Ord(Value[Index]); + b1 := Ord(Value[Index + 1]); + End; + 3: + Begin + b3 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b1 := Ord(Value[Index + 2]); + End; + 4: + Begin + b4 := Ord(Value[Index]); + b3 := Ord(Value[Index + 1]); + b2 := Ord(Value[Index + 2]); + b1 := Ord(Value[Index + 3]); + End; + end; + end; + Inc(Index, mb); +end; + +{==============================================================================} +function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString; +begin + if mb > 4 then + mb := 1; + SetLength(Result, mb); + if le then + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + end; + 3: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + end; + 4: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + Result[4] := AnsiChar(b4); + end; + end + else + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[2] := AnsiChar(b1); + Result[1] := AnsiChar(b2); + end; + 3: + begin + Result[3] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[1] := AnsiChar(b3); + end; + 4: + begin + Result[4] := AnsiChar(b1); + Result[3] := AnsiChar(b2); + Result[2] := AnsiChar(b3); + Result[1] := AnsiChar(b4); + end; + end; +end; + +{==============================================================================} +function UTF8toUCS4(const Value: AnsiString): AnsiString; +var + n, x, ul, m: Integer; + s: AnsiString; + w1, w2: Word; +begin + Result := ''; + n := 1; + while Length(Value) >= n do + begin + x := Ord(Value[n]); + Inc(n); + if x < 128 then + Result := Result + WriteMulti(x, 0, 0, 0, 4, false) + else + begin + m := 0; + if (x and $E0) = $C0 then + m := $1F; + if (x and $F0) = $E0 then + m := $0F; + if (x and $F8) = $F0 then + m := $07; + if (x and $FC) = $F8 then + m := $03; + if (x and $FE) = $FC then + m := $01; + ul := x and m; + s := IntToBin(ul, 0); + while Length(Value) >= n do + begin + x := Ord(Value[n]); + Inc(n); + if (x and $C0) = $80 then + s := s + IntToBin(x and $3F, 6) + else + begin + Dec(n); + Break; + end; + end; + ul := BinToInt(s); + w1 := ul div 65536; + w2 := ul mod 65536; + Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false); + end; + end; +end; + +{==============================================================================} +function UCS4toUTF8(const Value: AnsiString): AnsiString; +var + s, l, k: AnsiString; + b1, b2, b3, b4: Byte; + n, m, x, y: Integer; + b: Byte; +begin + Result := ''; + n := 1; + while Length(Value) >= n do + begin + ReadMulti(Value, n, 4, b1, b2, b3, b4, false); + if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then + Result := Result + AnsiChar(b1) + else + begin + x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536; + l := IntToBin(x, 0); + y := Length(l) div 6; + s := ''; + for m := 1 to y do + begin + k := Copy(l, Length(l) - 5, 6); + l := Copy(l, 1, Length(l) - 6); + b := BinToInt(k) or $80; + s := AnsiChar(b) + s; + end; + b := BinToInt(l); + case y of + 5: + b := b or $FC; + 4: + b := b or $F8; + 3: + b := b or $F0; + 2: + b := b or $E0; + 1: + b := b or $C0; + end; + s := AnsiChar(b) + s; + Result := Result + s; + end; + end; +end; + +{==============================================================================} +function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString; +var + n, i: Integer; + c: AnsiChar; + s, t: AnsiString; + shift: AnsiChar; + table: String; +begin + Result := ''; + n := 1; + if modified then + begin + shift := '&'; + table := TableBase64mod; + end + else + begin + shift := '+'; + table := TableBase64; + end; + while Length(Value) >= n do + begin + c := Value[n]; + Inc(n); + if c <> shift then + Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false) + else + begin + s := ''; + while Length(Value) >= n do + begin + c := Value[n]; + Inc(n); + if c = '-' then + Break; + if (c = '=') or (Pos(c, table) < 1) then + begin + Dec(n); + Break; + end; + s := s + c; + end; + if s = '' then + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false) + else + begin + if modified then + t := DecodeBase64mod(s) + else + t := DecodeBase64(s); + if not odd(length(t)) then + s := t + else + begin //ill-formed sequence + t := s; + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false); + for i := 1 to length(t) do + s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false); + end; + end; + Result := Result + s; + end; + end; +end; + +{==============================================================================} +function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString; +var + s: AnsiString; + b1, b2, b3, b4: Byte; + n, m: Integer; + shift: AnsiChar; +begin + Result := ''; + n := 1; + if modified then + shift := '&' + else + shift := '+'; + while Length(Value) >= n do + begin + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); + if (b2 = 0) and (b1 < 128) then + if AnsiChar(b1) = shift then + Result := Result + shift + '-' + else + Result := Result + AnsiChar(b1) + else + begin + s := AnsiChar(b2) + AnsiChar(b1); + while Length(Value) >= n do + begin + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); + if (b2 = 0) and (b1 < 128) then + begin + Dec(n, 2); + Break; + end; + s := s + AnsiChar(b2) + AnsiChar(b1); + end; + if modified then + s := EncodeBase64mod(s) + else + s := EncodeBase64(s); + m := Pos('=', s); + if m > 0 then + s := Copy(s, 1, m - 1); + Result := Result + shift + s + '-'; + end; + end; +end; + +{==============================================================================} +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; +begin + Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None); +end; + +{==============================================================================} +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; +begin + Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True); +end; + +{==============================================================================} + +function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString; +var + uni: Word; + n: Integer; + b1, b2, b3, b4: Byte; + SourceTable: array[128..255] of Word; + mbf: Byte; + lef: Boolean; + s: AnsiString; +begin + if CharFrom = UTF_8 then + s := UTF8toUCS4(Value) + else + if CharFrom = UTF_7 then + s := UTF7toUCS2(Value, False) + else + if CharFrom = UTF_7mod then + s := UTF7toUCS2(Value, True) + else + s := Value; + GetArray(CharFrom, SourceTable); + mbf := 1; + if CharFrom in SetTwo then + mbf := 2; + if CharFrom in SetFour then + mbf := 4; + lef := CharFrom in SetLe; + Result := ''; + n := 1; + while Length(s) >= n do + begin + ReadMulti(s, n, mbf, b1, b2, b3, b4, lef); + //handle BOM + if (b3 = 0) and (b4 = 0) then + begin + if (b1 = $FE) and (b2 = $FF) then + begin + lef := not lef; + continue; + end; + if (b1 = $FF) and (b2 = $FE) then + continue; + end; + if mbf = 1 then + if b1 > 127 then + begin + uni := SourceTable[b1]; + b1 := Lo(uni); + b2 := Hi(uni); + end; + Result := Result + WriteMulti(b1, b2, b3, b4, 2, False); + end; +end; + +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; +var + uni: Word; + n, m: Integer; + b: Byte; + b1, b2, b3, b4: Byte; + TargetTable: array[128..255] of Word; + mbt: Byte; + let: Boolean; + ucsstring, s, t: AnsiString; + cd: iconv_t; + f: Boolean; + NotNeedTransform: Boolean; + FromID, ToID: string; +begin + NotNeedTransform := (High(TransformTable) = 0); + if (CharFrom = CharTo) and NotNeedTransform then + begin + Result := Value; + Exit; + end; + FromID := GetIDFromCP(CharFrom); + ToID := GetIDFromCP(CharTo); + cd := Iconv_t(-1); + //do two-pass conversion. Transform to UCS-2 first. + if not DisableIconv then + cd := SynaIconvOpenIgnore('UCS-2BE', FromID); + try + if cd <> iconv_t(-1) then + SynaIconv(cd, Value, ucsstring) + else + ucsstring := InternalToUcs(Value, CharFrom); + finally + SynaIconvClose(cd); + end; + //here we allways have ucstring with UCS-2 encoding + //second pass... from UCS-2 to target encoding. + if not DisableIconv then + if translit then + cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE') + else + cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE'); + try + if (cd <> iconv_t(-1)) and NotNeedTransform then + begin + if CharTo = UTF_7 then + ucsstring := ucsstring + #0 + '-'; + //when transformtable is not needed and Iconv know target charset, + //do it fast by one call. + SynaIconv(cd, ucsstring, Result); + if CharTo = UTF_7 then + Delete(Result, Length(Result), 1); + end + else + begin + GetArray(CharTo, TargetTable); + mbt := 1; + if CharTo in SetTwo then + mbt := 2; + if CharTo in SetFour then + mbt := 4; + let := CharTo in SetLe; + b3 := 0; + b4 := 0; + Result := ''; + for n:= 0 to (Length(ucsstring) div 2) - 1 do + begin + s := Copy(ucsstring, n * 2 + 1, 2); + b2 := Ord(s[1]); + b1 := Ord(s[2]); + uni := b2 * 256 + b1; + if not NotNeedTransform then + begin + uni := ReplaceUnicode(uni, TransformTable); + b1 := Lo(uni); + b2 := Hi(uni); + s[1] := AnsiChar(b2); + s[2] := AnsiChar(b1); + end; + if cd <> iconv_t(-1) then + begin + if CharTo = UTF_7 then + s := s + #0 + '-'; + SynaIconv(cd, s, t); + if CharTo = UTF_7 then + Delete(t, Length(t), 1); + Result := Result + t; + end + else + begin + f := True; + if mbt = 1 then + if uni > 127 then + begin + f := False; + b := 0; + for m := 128 to 255 do + if TargetTable[m] = uni then + begin + b := m; + f := True; + Break; + end; + b1 := b; + b2 := 0; + end + else + b1 := Lo(uni); + if not f then + if translit then + begin + b1 := Ord(NotFoundChar); + b2 := 0; + f := True; + end; + if f then + Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let) + end; + end; + if cd = iconv_t(-1) then + begin + if CharTo = UTF_7 then + Result := UCS2toUTF7(Result, false); + if CharTo = UTF_7mod then + Result := UCS2toUTF7(Result, true); + if CharTo = UTF_8 then + Result := UCS4toUTF8(Result); + end; + end; + finally + SynaIconvClose(cd); + end; +end; + +{==============================================================================} +{$IF NOT(DEFINED(MSWINDOWS)) and NOT(DEFINED(ULTIBO))} + +function GetCurCP: TMimeChar; +begin + {$IFNDEF FPC} + Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + //How to get system codepage without LIBC? + Result := UTF_8; +{ TODO : Waiting for FPC 2.8 solution } + {$ENDIF} +end; + +function GetCurOEMCP: TMimeChar; +begin + Result := GetCurCP; +end; + +{$ELSE} + +function CPToMimeChar(Value: Integer): TMimeChar; +begin + case Value of + 437, 850, 20127: + Result := ISO_8859_1; //I know, it is not ideal! + 737: + Result := CP737; + 775: + Result := CP775; + 852: + Result := CP852; + 855: + Result := CP855; + 857: + Result := CP857; + 858: + Result := CP858; + 860: + Result := CP860; + 861: + Result := CP861; + 862: + Result := CP862; + 863: + Result := CP863; + 864: + Result := CP864; + 865: + Result := CP865; + 866: + Result := CP866; + 869: + Result := CP869; + 874: + Result := ISO_8859_15; + 895: + Result := CP895; + 932: + Result := CP932; + 936: + Result := CP936; + 949: + Result := CP949; + 950: + Result := CP950; + 1200: + Result := UCS_2LE; + 1201: + Result := UCS_2; + 1250: + Result := CP1250; + 1251: + Result := CP1251; + 1253: + Result := CP1253; + 1254: + Result := CP1254; + 1255: + Result := CP1255; + 1256: + Result := CP1256; + 1257: + Result := CP1257; + 1258: + Result := CP1258; + 1361: + Result := CP1361; + 10000: + Result := MAC; + 10004: + Result := MACAR; + 10005: + Result := MACHEB; + 10006: + Result := MACGR; + 10007: + Result := MACCYR; + 10010: + Result := MACRO; + 10017: + Result := MACUK; + 10021: + Result := MACTH; + 10029: + Result := MACCE; + 10079: + Result := MACICE; + 10081: + Result := MACTU; + 10082: + Result := MACCRO; + 12000: + Result := UCS_4LE; + 12001: + Result := UCS_4; + 20866: + Result := KOI8_R; + 20932: + Result := JIS_X0208; + 20936: + Result := GB2312; + 21866: + Result := KOI8_U; + 28591: + Result := ISO_8859_1; + 28592: + Result := ISO_8859_2; + 28593: + Result := ISO_8859_3; + 28594: + Result := ISO_8859_4; + 28595: + Result := ISO_8859_5; + 28596, 708: + Result := ISO_8859_6; + 28597: + Result := ISO_8859_7; + 28598, 38598: + Result := ISO_8859_8; + 28599: + Result := ISO_8859_9; + 28605: + Result := ISO_8859_15; + 50220: + Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana + 50221: + Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana + 50222: + Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989 + 50225: + Result := ISO_2022_KR; + 50227: + Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese + 50229: + Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese + 51932: + Result := EUC_JP; + 51936: + Result := GB2312; + 51949: + Result := EUC_KR; + 52936: + Result := HZ; + 54936: + Result := GB18030; + 65000: + Result := UTF_7; + 65001: + Result := UTF_8; + 0: + Result := UCS_2LE; + else + Result := CP1252; + end; +end; + +function GetCurCP: TMimeChar; +begin + Result := CPToMimeChar(GetACP); +end; + +function GetCurOEMCP: TMimeChar; +begin + Result := CPToMimeChar(GetOEMCP); +end; +{$ENDIF} + +{==============================================================================} +function NeedCharsetConversion(const Value: AnsiString): Boolean; +var + n: Integer; +begin + Result := False; + for n := 1 to Length(Value) do + if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} +function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar; + CharTo: TMimeSetChar): TMimeChar; +var + n: Integer; + max: Integer; + s, t, u: AnsiString; + CharSet: TMimeChar; +begin + Result := ISO_8859_1; + s := Copy(Value, 1, 1024); //max first 1KB for next procedure + max := 0; + for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do + begin + CharSet := TMimeChar(n); + if CharSet in CharTo then + begin + t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False); + u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False); + if s = u then + begin + Result := CharSet; + Exit; + end; + if Length(u) > max then + begin + Result := CharSet; + max := Length(u); + end; + end; + end; +end; + +{==============================================================================} +function GetBOM(Value: TMimeChar): AnsiString; +begin + Result := ''; + case Value of + UCS_2: + Result := #$fe + #$ff; + UCS_4: + Result := #$00 + #$00 + #$fe + #$ff; + UCS_2LE: + Result := #$ff + #$fe; + UCS_4LE: + Result := #$ff + #$fe + #$00 + #$00; + UTF_8: + Result := #$ef + #$bb + #$bf; + end; +end; + +{==============================================================================} +function GetCPFromID(Value: AnsiString): TMimeChar; +begin + Value := UpperCase(Value); + if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then + Result := CP895 + else + if Pos('MUTF-7', Value) > 0 then + Result := UTF_7mod + else + Result := GetCPFromIconvID(Value); +end; + +{==============================================================================} +function GetIDFromCP(Value: TMimeChar): AnsiString; +begin + case Value of + CP895: + Result := 'CP-895'; + UTF_7mod: + Result := 'mUTF-7'; + else + Result := GetIconvIDFromCP(Value); + end; +end; + +{==============================================================================} +function StringToWide(const Value: AnsiString): WideString; +var + n: integer; + x, y: integer; +begin + SetLength(Result, Length(Value) div 2); + for n := 1 to Length(Value) div 2 do + begin + x := Ord(Value[((n-1) * 2) + 1]); + y := Ord(Value[((n-1) * 2) + 2]); + Result[n] := WideChar(x * 256 + y); + end; +end; + +{==============================================================================} +function WideToString(const Value: WideString): AnsiString; +var + n: integer; + x: integer; +begin + SetLength(Result, Length(Value) * 2); + for n := 1 to Length(Value) do + begin + x := Ord(Value[n]); + Result[((n-1) * 2) + 1] := AnsiChar(x div 256); + Result[((n-1) * 2) + 2] := AnsiChar(x mod 256); + end; +end; + +{==============================================================================} +initialization +begin + IconvArr[0].Charset := ISO_8859_1; + IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1 ISO88591 ISOIR100'; + IconvArr[1].Charset := UTF_8; + IconvArr[1].Charname := 'UTF-8 UTF8'; + IconvArr[2].Charset := UCS_2; + IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE UCS2'; + IconvArr[3].Charset := UCS_2; + IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11 UNICODE11 UCS2BE UCS2-BE'; + IconvArr[4].Charset := UCS_2LE; + IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE UCS2LE UCS2-LE'; + IconvArr[5].Charset := UCS_4; + IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4 UCS4 ISO10646UCS4'; + IconvArr[6].Charset := UCS_4; + IconvArr[6].Charname := 'UCS-4BE UCS4BE UCS4-BE'; + IconvArr[7].Charset := UCS_2LE; + IconvArr[7].Charname := 'UCS-4LE UCS4LE UCS4-LE'; + IconvArr[8].Charset := UTF_16; + IconvArr[8].Charname := 'UTF-16 UTF16'; + IconvArr[9].Charset := UTF_16; + IconvArr[9].Charname := 'UTF-16BE UTF16BE UTF16-BE'; + IconvArr[10].Charset := UTF_16LE; + IconvArr[10].Charname := 'UTF-16LE UTF16LE UTF16-LE'; + IconvArr[11].Charset := UTF_32; + IconvArr[11].Charname := 'UTF-32 UTF32'; + IconvArr[12].Charset := UTF_32; + IconvArr[12].Charname := 'UTF-32BE UTF32BE UTF32-BE'; + IconvArr[13].Charset := UTF_32; + IconvArr[13].Charname := 'UTF-32LE UTF32LE UTF32-LE'; + IconvArr[14].Charset := UTF_7; + IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7 UTF7 UNICODE11UTF7'; + IconvArr[15].Charset := C99; + IconvArr[15].Charname := 'C99'; + IconvArr[16].Charset := JAVA; + IconvArr[16].Charname := 'JAVA'; + IconvArr[17].Charset := ISO_8859_1; + IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII USASCII ISOIR6'; + IconvArr[18].Charset := ISO_8859_2; + IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2 ISO88592 ISOIR101'; + IconvArr[19].Charset := ISO_8859_3; + IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3 ISO88593 ISOIR109'; + IconvArr[20].Charset := ISO_8859_4; + IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4 ISO88594 ISOIR110'; + IconvArr[21].Charset := ISO_8859_5; + IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC ISOIR144'; + IconvArr[22].Charset := ISO_8859_6; + IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC ISOIR127'; + IconvArr[23].Charset := ISO_8859_7; + IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK ISOIR126 ECMA118 ELOT928'; + IconvArr[24].Charset := ISO_8859_8; + IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I ISOIR138'; + IconvArr[25].Charset := ISO_8859_9; + IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5 ISOIR148'; + IconvArr[26].Charset := ISO_8859_10; + IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6 ISOIR157'; + IconvArr[27].Charset := ISO_8859_13; + IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7 ISOIR179'; + IconvArr[28].Charset := ISO_8859_14; + IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8 ISOIR199 ISOCELTIC'; + IconvArr[29].Charset := ISO_8859_15; + IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998 ISOIR203'; + IconvArr[30].Charset := ISO_8859_16; + IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000 ISOIR226'; + IconvArr[31].Charset := KOI8_R; + IconvArr[31].Charname := 'KOI8-R CSKOI8R KOI8R'; + IconvArr[32].Charset := KOI8_U; + IconvArr[32].Charname := 'KOI8-U KOI8U'; + IconvArr[33].Charset := KOI8_RU; + IconvArr[33].Charname := 'KOI8-RU KOI8RU'; + IconvArr[34].Charset := CP1250; + IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE WINDOWS1250 MSEE'; + IconvArr[35].Charset := CP1251; + IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL WINDOWS1251 MSCYRL'; + IconvArr[36].Charset := CP1252; + IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI WINDOWS1252 MSANSI'; + IconvArr[37].Charset := CP1253; + IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK WINDOWS1253 MSGREEK'; + IconvArr[38].Charset := CP1254; + IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK WINDOWS1254 MSTURK'; + IconvArr[39].Charset := CP1255; + IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR WINDOWS1255 MSHEBR'; + IconvArr[40].Charset := CP1256; + IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB WINDOWS1256 MSARAB'; + IconvArr[41].Charset := CP1257; + IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM WINDOWS1257'; + IconvArr[42].Charset := CP1258; + IconvArr[42].Charname := 'WINDOWS-1258 CP1258 WINDOWS1258'; + IconvArr[43].Charset := ISO_8859_1; + IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL'; + IconvArr[44].Charset := CP862; + IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW'; + IconvArr[45].Charset := CP866; + IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866'; + IconvArr[46].Charset := MAC; + IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH'; + IconvArr[47].Charset := MACCE; + IconvArr[47].Charname := 'MACCENTRALEUROPE'; + IconvArr[48].Charset := MACICE; + IconvArr[48].Charname := 'MACICELAND'; + IconvArr[49].Charset := MACCRO; + IconvArr[49].Charname := 'MACCROATIAN'; + IconvArr[50].Charset := MACRO; + IconvArr[50].Charname := 'MACROMANIA'; + IconvArr[51].Charset := MACCYR; + IconvArr[51].Charname := 'MACCYRILLIC'; + IconvArr[52].Charset := MACUK; + IconvArr[52].Charname := 'MACUKRAINE'; + IconvArr[53].Charset := MACGR; + IconvArr[53].Charname := 'MACGREEK'; + IconvArr[54].Charset := MACTU; + IconvArr[54].Charname := 'MACTURKISH'; + IconvArr[55].Charset := MACHEB; + IconvArr[55].Charname := 'MACHEBREW'; + IconvArr[56].Charset := MACAR; + IconvArr[56].Charname := 'MACARABIC'; + IconvArr[57].Charset := MACTH; + IconvArr[57].Charname := 'MACTHAI'; + IconvArr[58].Charset := ROMAN8; + IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8 HPROMAN8 HP-ROMAN-8 HPROMAN-8'; + IconvArr[59].Charset := NEXTSTEP; + IconvArr[59].Charname := 'NEXTSTEP'; + IconvArr[60].Charset := ARMASCII; + IconvArr[60].Charname := 'ARMSCII-8 ARMSCII8'; + IconvArr[61].Charset := GEORGIAN_AC; + IconvArr[61].Charname := 'GEORGIAN-ACADEMY GEORGIANACADEMY'; + IconvArr[62].Charset := GEORGIAN_PS; + IconvArr[62].Charname := 'GEORGIAN-PS GEORGIANPS'; + IconvArr[63].Charset := KOI8_T; + IconvArr[63].Charname := 'KOI8-T KOI8T'; + IconvArr[64].Charset := MULELAO; + IconvArr[64].Charname := 'MULELAO-1 MULELAO1'; + IconvArr[65].Charset := CP1133; + IconvArr[65].Charname := 'CP1133 IBM-CP1133 IBMCP1133'; + IconvArr[66].Charset := TIS620; + IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1 ISOIR166'; + IconvArr[67].Charset := CP874; + IconvArr[67].Charname := 'CP874 WINDOWS-874 WINDOWS874'; + IconvArr[68].Charset := VISCII; + IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII'; + IconvArr[69].Charset := TCVN; + IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993 TCVN5712'; + IconvArr[70].Charset := ISO_IR_14; + IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO ISOIR14'; + IconvArr[71].Charset := JIS_X0201; + IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA JISX02011976 JISX0201'; + IconvArr[72].Charset := JIS_X0208; + IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208 ISOIR87 JISC6226-1983 JIS-C6226-1983 JIS_C62261983'; + IconvArr[73].Charset := JIS_X0212; + IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990 ISOIR159'; + IconvArr[74].Charset := GB1988_80; + IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988 ISOIR57'; + IconvArr[75].Charset := GB2312_80; + IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280 ISOIR58 GB231280 GB2312-80'; + IconvArr[76].Charset := ISO_IR_165; + IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165 ISOIR165 CNGBIOSIR165'; + IconvArr[77].Charset := ISO_IR_149; + IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987 ISOIR149'; + IconvArr[78].Charset := EUC_JP; + IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE'; + IconvArr[79].Charset := SHIFT_JIS; + IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS SHIFTJIS'; + IconvArr[80].Charset := CP932; + IconvArr[80].Charname := 'CP932'; + IconvArr[81].Charset := ISO_2022_JP; + IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP ISO2022JP'; + IconvArr[82].Charset := ISO_2022_JP1; + IconvArr[82].Charname := 'ISO-2022-JP-1 ISO-2022-JP1 ISO-2022JP1 ISO2022-JP1 ISO2022JP1'; + IconvArr[83].Charset := ISO_2022_JP2; + IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2 ISO-2022-JP2 ISO-2022JP2 ISO2022-JP2 ISO2022JP2'; + IconvArr[84].Charset := GB2312; + IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312'; + IconvArr[85].Charset := CP936; + IconvArr[85].Charname := 'CP936 GBK'; + IconvArr[86].Charset := GB18030; + IconvArr[86].Charname := 'GB18030'; + IconvArr[87].Charset := ISO_2022_CN; + IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN ISO2022CN ISO-2022CN ISO2022-CN'; + IconvArr[88].Charset := ISO_2022_CNE; + IconvArr[88].Charname := 'ISO-2022-CN-EXT ISO2022CNEXT ISO-2022CNEXT ISO-2022-CNEXT ISO2022-CNEXT ISO2022-CN-EXT'; + IconvArr[89].Charset := HZ; + IconvArr[89].Charname := 'HZ HZ-GB-2312 HZGB2312'; + IconvArr[90].Charset := EUC_TW; + IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW'; + IconvArr[91].Charset := BIG5; + IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5 CNBIG5'; + IconvArr[92].Charset := CP950; + IconvArr[92].Charname := 'CP950'; + IconvArr[93].Charset := BIG5_HKSCS; + IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS BIG5HKSCS'; + IconvArr[94].Charset := EUC_KR; + IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR EUCKR'; + IconvArr[95].Charset := CP949; + IconvArr[95].Charname := 'CP949 UHC'; + IconvArr[96].Charset := CP1361; + IconvArr[96].Charname := 'CP1361 JOHAB'; + IconvArr[97].Charset := ISO_2022_KR; + IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR ISO2022KR'; + IconvArr[98].Charset := ISO_8859_1; + IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437'; + IconvArr[99].Charset := CP737; + IconvArr[99].Charname := 'CP737'; + IconvArr[100].Charset := CP775; + IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC'; + IconvArr[101].Charset := CP852; + IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852'; + IconvArr[102].Charset := CP853; + IconvArr[102].Charname := 'CP853'; + IconvArr[103].Charset := CP855; + IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855'; + IconvArr[104].Charset := CP857; + IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857'; + IconvArr[105].Charset := CP858; + IconvArr[105].Charname := 'CP858'; + IconvArr[106].Charset := CP860; + IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860'; + IconvArr[107].Charset := CP861; + IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861 CPIS'; + IconvArr[108].Charset := CP863; + IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863'; + IconvArr[109].Charset := CP864; + IconvArr[109].Charname := 'CP864 IBM864 CSIBM864'; + IconvArr[110].Charset := CP865; + IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865'; + IconvArr[111].Charset := CP869; + IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869 CPGR'; + IconvArr[112].Charset := CP1125; + IconvArr[112].Charname := 'CP1125'; +end; + +end. diff --git a/synacode.pas b/synacode.pas new file mode 100644 index 0000000..0d8dea1 --- /dev/null +++ b/synacode.pas @@ -0,0 +1,1474 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.002.003 | +|==============================================================================| +| Content: Coding and decoding support | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Various encoding and decoding support)} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} +{$TYPEDADDRESS OFF} + +{$IFDEF CIL} + {$DEFINE SYNACODE_NATIVE} +{$ENDIF} +{$IFDEF FPC_BIG_ENDIAN} + {$DEFINE SYNACODE_NATIVE} +{$ENDIF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synacode; + +interface + +uses + SysUtils; + +type + TSpecials = TSysCharSet; + +const + SPACE_CHAR: AnsiChar = #32; + + HMAC_MD5_IPAD_CHAR: AnsiChar = #$36; + HMAC_MD5_OPAD_CHAR: AnsiChar = #$5C; + + HMAC_SHA1_IPAD_CHAR: AnsiChar = #$36; + HMAC_SHA1_OPAD_CHAR: AnsiChar = #$5C; + + SpecialChar: TSpecials = + ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', + '"', '_']; + NonAsciiChar: TSpecials = + [#0..#31, #127..#255]; + URLFullSpecialChar: TSpecials = + [';', '/', '?', ':', '@', '=', '&', '#', '+']; + URLSpecialChar: TSpecials = + [#$00..#$20, '<', '>', '"', '%', '{', '}', '|', '\', '^', '[', ']', '`', #$7F..#$FF]; + TableBase64 = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; + TableBase64mod = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; + TableUU = + '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; + TableXX = + '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; + ReTablebase64 = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 + +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 + +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 + +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableUU = + #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C + +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 + +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 + +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 + +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableXX = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 + +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A + +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B + +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 + +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + +{:Decodes triplet encoding with a given character delimiter. It is used for + decoding quoted-printable or URL encoding.} +function DecodeTriplet(const Value: String; Delimiter: Char): String; + +{:Decodes a string from quoted printable form. (also decodes triplet sequences + like '=7F')} +function DecodeQuotedPrintable(const Value: String): String; + +{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} +function DecodeURL(const Value: String): String; + +{:Performs triplet encoding with a given character delimiter. Used for encoding + quoted-printable or URL encoding.} +function EncodeTriplet(const Value: String; Delimiter: Char; + Specials: TSpecials): String; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) + are encoded.} +function EncodeQuotedPrintable(const Value: String): String; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and + @link(SpecialChar) are encoded.} +function EncodeSafeQuotedPrintable(const Value: String): String; + +{:Encodes a string to URL format. Used for encoding data from a form field in + HTTP, etc. (Encodes all critical characters including characters used as URL + delimiters ('/',':', etc.)} +function EncodeURLElement(const Value: String): String; + +{:Encodes a string to URL format. Used to encode critical characters in all + URLs.} +function EncodeURL(const Value: String): String; + +{:Decode 4to3 encoding with given table. If some element is not found in table, + first item from table is used. This is good for buggy coded items by Microsoft + Outlook. This software sometimes using wrong table for UUcode, where is used + ' ' instead '`'.} +function Decode4to3(const Value, Table: String): String; + +{:Decode 4to3 encoding with given REVERSE table. Using this function with +reverse table is much faster then @link(Decode4to3). This function is used +internally for Base64, UU or XX decoding.} +function Decode4to3Ex(const Value, Table: String): String; + +{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} +function Encode3to4(const Value, Table: String): String; + +{:Decode string from base64 format.} +function DecodeBase64(const Value: String): String; + +{:Encodes a string to base64 format.} +function EncodeBase64(const Value: String): String; + +{:Decode string from modified base64 format. (used in IMAP, for example.)} +function DecodeBase64mod(const Value: String): String; + +{:Encodes a string to modified base64 format. (used in IMAP, for example.)} +function EncodeBase64mod(const Value: String): String; + +{:Decodes a string from UUcode format.} +function DecodeUU(const Value: String): String; + +{:encode UUcode. it encode only datas, you must also add header and footer for + proper encode.} +function EncodeUU(const Value: String): String; + +{:Decodes a string from XXcode format.} +function DecodeXX(const Value: String): String; + +{:decode line with Yenc code. This code is sometimes used in newsgroups.} +function DecodeYEnc(const Value: String): String; + +{:Returns a new CRC32 value after adding a new byte of data.} +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; + +{:return CRC32 from a value string.} +function Crc32(const Value: String): Integer; + +{:Returns a new CRC16 value after adding a new byte of data.} +function UpdateCrc16(Value: Byte; Crc16: Word): Word; + +{:return CRC16 from a value string.} +function Crc16(const Value: String): Word; + +{:Returns a binary string with a RSA-MD5 hashing of "Value" string.} +function MD5(const Value: String): String; + +{:Returns a binary string with HMAC-MD5 hash.} +function HMAC_MD5(const Text: String; Key: String): String; + +{:Returns a binary string with a RSA-MD5 hashing of string what is constructed + by repeating "value" until length is "Len".} +function MD5LongHash(const Value: String; Len: integer): String; + +{:Returns a binary string with a SHA-1 hashing of "Value" string.} +function SHA1(const Value: String): String; + +{:Returns a binary string with HMAC-SHA1 hash.} +function HMAC_SHA1(const Text: String; Key: String): String; + +{:Returns a binary string with a SHA-1 hashing of string what is constructed + by repeating "value" until length is "Len".} +function SHA1LongHash(const Value: String; Len: integer): String; + +{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} +function MD4(const Value: String): String; + +implementation + +const + + Crc32Tab: array[0..255] of Integer = ( + Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), + Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), + Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), + Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), + Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), + Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), + Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), + Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), + Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), + Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), + Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), + Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), + Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), + Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), + Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), + Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), + Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), + Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), + Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), + Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), + Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), + Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), + Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), + Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), + Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), + Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), + Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), + Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), + Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), + Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), + Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), + Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), + Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), + Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), + Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), + Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), + Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), + Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), + Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), + Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), + Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), + Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), + Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), + Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), + Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), + Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), + Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), + Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), + Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), + Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), + Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), + Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), + Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), + Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), + Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), + Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), + Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), + Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), + Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), + Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), + Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), + Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), + Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), + Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) + ); + + Crc16Tab: array[0..255] of Word = ( + $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, + $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, + $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, + $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, + $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, + $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, + $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, + $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, + $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, + $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, + $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, + $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, + $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, + $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, + $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, + $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, + $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, + $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, + $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, + $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, + $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, + $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, + $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, + $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, + $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, + $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, + $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, + $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, + $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, + $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, + $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, + $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 + ); + +procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); +{$IFDEF SYNACODE_NATIVE} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF SYNACODE_NATIVE} + for n := 0 to ((high(ArByte) + 1) div 4) - 1 do + ArLong[n] := ArByte[n * 4 + 0] + + (ArByte[n * 4 + 1] shl 8) + + (ArByte[n * 4 + 2] shl 16) + + (ArByte[n * 4 + 3] shl 24); + {$ELSE} + Move(ArByte[0], ArLong[0], High(ArByte) + 1); + {$ENDIF} +end; + +procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); +{$IFDEF SYNACODE_NATIVE} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF SYNACODE_NATIVE} + for n := 0 to high(ArLong) do + begin + ArByte[n * 4 + 0] := ArLong[n] and $000000FF; + ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; + ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; + ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; + end; + {$ELSE} + Move(ArLong[0], ArByte[0], High(ArByte) + 1); + {$ENDIF} +end; + +type + TMDCtx = record + State: array[0..3] of Integer; + Count: array[0..1] of Integer; + BufAnsiChar: array[0..63] of Byte; + BufLong: array[0..15] of Integer; + end; + TSHA1Ctx= record + Hi, Lo: integer; + Buffer: array[0..63] of byte; + Index: integer; + Hash: array[0..4] of Integer; + HashByte: array[0..19] of byte; + end; + + TMDTransform = procedure(var Buf: array of Integer; const Data: array of Integer); + +{==============================================================================} + +function DecodeTriplet(const Value: String; Delimiter: Char): String; +var + x, l, lv: Integer; + c: Char; + b: Byte; + bad: Boolean; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + l := 1; + while x <= lv do + begin + c := Value[x]; + Inc(x); + if c <> Delimiter then + begin + Result[l] := c; + Inc(l); + end + else + if x < lv then + begin + Case Value[x] Of + #13: + if (Value[x + 1] = #10) then + Inc(x, 2) + else + Inc(x); + #10: + if (Value[x + 1] = #13) then + Inc(x, 2) + else + Inc(x); + else + begin + bad := False; + Case Value[x] Of + '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; + 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; + else + begin + b := 0; + bad := True; + end; + end; + Case Value[x + 1] Of + '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); + 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); + else + bad := True; + end; + if bad then + begin + Result[l] := c; + Inc(l); + end + else + begin + Inc(x, 2); + Result[l] := Char(b); + Inc(l); + end; + end; + end; + end + else + break; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function DecodeQuotedPrintable(const Value: String): String; +begin + Result := DecodeTriplet(Value, '='); +end; + +{==============================================================================} + +function DecodeURL(const Value: String): String; +begin + Result := DecodeTriplet(Value, '%'); +end; + +{==============================================================================} + +function EncodeTriplet(const Value: String; Delimiter: Char; + Specials: TSpecials): String; +var + n, l: Integer; + s: String; + c: Char; +begin + SetLength(Result, Length(Value) * 3); + l := 1; + for n := 1 to Length(Value) do + begin + c := Value[n]; + if CharInSet(c, Specials) then + begin + Result[l] := Delimiter; + Inc(l); + s := IntToHex(Ord(c), 2); + Result[l] := s[1]; + Inc(l); + Result[l] := s[2]; + Inc(l); + end + else + begin + Result[l] := c; + Inc(l); + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function EncodeQuotedPrintable(const Value: String): String; +begin + Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeSafeQuotedPrintable(const Value: String): String; +begin + Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeURLElement(const Value: String): String; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); +end; + +{==============================================================================} + +function EncodeURL(const Value: String): String; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar); +end; + +{==============================================================================} + +function Decode4to3(const Value, Table: String): String; +var + x, y, n, l: Integer; + d: array[0..3] of Byte; +begin + SetLength(Result, Length(Value)); + x := 1; + l := 1; + while x <= Length(Value) do + begin + for n := 0 to 3 do + begin + if x > Length(Value) then + d[n] := 64 + else + begin + y := Pos(Value[x], Table); + if y < 1 then + y := 1; + d[n] := y - 1; + end; + Inc(x); + end; + Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Inc(l); + if d[2] <> 64 then + begin + Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Inc(l); + if d[3] <> 64 then + begin + Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F)); + Inc(l); + end; + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} +function Decode4to3Ex(const Value, Table: String): String; +var + x, y, lv: Integer; + d: integer; + dl: integer; + c: byte; + p: integer; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + dl := 4; + d := 0; + p := 1; + while x <= lv do + begin + y := Ord(Value[x]); + if y in [33..127] then + c := Ord(Table[y - 32]) + else + c := 64; + Inc(x); + if c > 63 then + continue; + d := (d shl 6) or c; + dec(dl); + if dl <> 0 then + continue; + Result[p] := Char((d shr 16) and $ff); + inc(p); + Result[p] := Char((d shr 8) and $ff); + inc(p); + Result[p] := Char(d and $ff); + inc(p); + d := 0; + dl := 4; + end; + case dl of + 1: + begin + d := d shr 2; + Result[p] := Char((d shr 8) and $ff); + inc(p); + Result[p] := Char(d and $ff); + inc(p); + end; + 2: + begin + d := d shr 4; + Result[p] := Char(d and $ff); + inc(p); + end; + end; + SetLength(Result, p - 1); +end; + +{==============================================================================} + +function Encode3to4(const Value, Table: String): String; +var + c: Byte; + n, l: Integer; + Count: Integer; + DOut: array[0..3] of Byte; +begin + setlength(Result, ((Length(Value) + 2) div 3) * 4); + l := 1; + Count := 1; + while Count <= Length(Value) do + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[0] := (c and $FC) shr 2; + DOut[1] := (c and $03) shl 4; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[1] := DOut[1] + (c and $F0) shr 4; + DOut[2] := (c and $0F) shl 2; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[2] := DOut[2] + (c and $C0) shr 6; + DOut[3] := (c and $3F); + end + else + begin + DOut[3] := $40; + end; + end + else + begin + DOut[2] := $40; + DOut[3] := $40; + end; + for n := 0 to 3 do + begin + if (DOut[n] + 1) <= Length(Table) then + begin + Result[l] := Table[DOut[n] + 1]; + Inc(l); + end; + end; + end; + SetLength(Result, l - 1); +end; + +{==============================================================================} + +function DecodeBase64(const Value: String): String; +begin + Result := Decode4to3Ex(Value, ReTableBase64); +end; + +{==============================================================================} + +function EncodeBase64(const Value: String): String; +begin + Result := Encode3to4(Value, TableBase64); +end; + +{==============================================================================} + +function DecodeBase64mod(const Value: String): String; +begin + Result := Decode4to3(Value, TableBase64mod); +end; + +{==============================================================================} + +function EncodeBase64mod(const Value: String): String; +begin + Result := Encode3to4(Value, TableBase64mod); +end; + +{==============================================================================} + +function DecodeUU(const Value: String): String; +var + s: String; + uut: String; + x: Integer; +begin + Result := ''; + uut := TableUU; + s := trim(UpperCase(Value)); + if s = '' then Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + if Pos('TABLE', s) = 1 then + Exit; //ignore Table yet (set custom UUT) + //begin decoding + x := Pos(Value[1], uut) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght UU line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(SPACE_CHAR, x - length(s)); + Result := Decode4to3(s, uut); +end; + +{==============================================================================} + +function EncodeUU(const Value: String): String; +begin + Result := ''; + if Length(Value) < Length(TableUU) then + Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); +end; + +{==============================================================================} + +function DecodeXX(const Value: String): String; +var + s: String; + x: Integer; +begin + Result := ''; + s := trim(UpperCase(Value)); + if s = '' then + Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + //begin decoding + x := Pos(Value[1], TableXX) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght XX line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(SPACE_CHAR, x - length(s)); + Result := Decode4to3(s, TableXX); +end; + +{==============================================================================} + +function DecodeYEnc(const Value: String): String; +var + C : Byte; + i: integer; +begin + Result := ''; + i := 1; + while i <= Length(Value) do + begin + c := Ord(Value[i]); + Inc(i); + if c = Ord('=') then + begin + c := Ord(Value[i]); + Inc(i); + Dec(c, 64); + end; + Dec(C, 42); + Result := Result + Char(C); + end; +end; + +{==============================================================================} + +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; +begin + Result := (Crc32 shr 8) + xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; +end; + +{==============================================================================} + +function Crc32(const Value: String): Integer; +var + n: Integer; +begin + Result := Integer($FFFFFFFF); + for n := 1 to Length(Value) do + Result := UpdateCrc32(Ord(Value[n]), Result); + Result := not Result; +end; + +{==============================================================================} + +function UpdateCrc16(Value: Byte; Crc16: Word): Word; +begin + Result := ((Crc16 shr 8) and $00FF) xor + crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; +end; + +{==============================================================================} + +function Crc16(const Value: String): Word; +var + n: Integer; +begin + Result := $FFFF; + for n := 1 to Length(Value) do + Result := UpdateCrc16(Ord(Value[n]), Result); +end; + +{==============================================================================} + +procedure MDInit(var MDContext: TMDCtx); +var + n: integer; +begin + MDContext.Count[0] := 0; + MDContext.Count[1] := 0; + for n := 0 to high(MDContext.BufAnsiChar) do + MDContext.BufAnsiChar[n] := 0; + for n := 0 to high(MDContext.BufLong) do + MDContext.BufLong[n] := 0; + MDContext.State[0] := Integer($67452301); + MDContext.State[1] := Integer($EFCDAB89); + MDContext.State[2] := Integer($98BADCFE); + MDContext.State[3] := Integer($10325476); +end; + +procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + + procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Z xor (X and (Y xor Z))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (Z and (X xor Y))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (X xor Y xor Z) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (X or not Z)) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); + Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); + Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); + Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); + Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); + Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); + Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); + Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); + Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); + Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); + Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); + Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); + Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); + Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); + Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); + Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); + + Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); + Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); + Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); + Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); + Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); + Round2(D, A, B, C, Data[10] + Longint($02441453), 9); + Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); + Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); + Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); + Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); + Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); + Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); + Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); + Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); + Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); + Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); + + Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); + Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); + Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); + Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); + Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); + Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); + Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); + Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); + Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); + Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); + Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); + Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); + Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); + Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); + Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); + Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); + + Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); + Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); + Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); + Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); + Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); + Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); + Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); + Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); + Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); + Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); + Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); + Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); + Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); + Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); + Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); + Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +//fixed by James McAdams +procedure MDUpdate(var MDContext: TMDCtx; const Data: String; transform: TMDTransform); +var + Index, partLen, InputLen, I: integer; +{$IFDEF SYNACODE_NATIVE} + n: integer; +{$ENDIF} +begin + InputLen := Length(Data); + with MDContext do + begin + Index := (Count[0] shr 3) and $3F; + Inc(Count[0], InputLen shl 3); + if Count[0] < (InputLen shl 3) then + Inc(Count[1]); + Inc(Count[1], InputLen shr 29); + partLen := 64 - Index; + if InputLen >= partLen then + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF SYNACODE_NATIVE} + for n := 1 to partLen do + BufAnsiChar[index - 1 + n] := Ord(Data[n]); + {$ELSE} + Move(Data[1], BufAnsiChar[Index], partLen); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + I := partLen; + while I + 63 < InputLen do + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF SYNACODE_NATIVE} + for n := 1 to 64 do + BufAnsiChar[n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar, 64); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + inc(I, 64); + end; + Index := 0; + end + else + I := 0; + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF SYNACODE_NATIVE} + for n := 1 to InputLen-I do + BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar[Index], InputLen-I); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + end +end; + +function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): String; +var + Cnt: Word; + P: Byte; + digest: array[0..15] of Byte; + i: Integer; + n: integer; +begin + for I := 0 to 15 do + Digest[I] := I + 1; + with MDContext do + begin + Cnt := (Count[0] shr 3) and $3F; + P := Cnt; + BufAnsiChar[P] := $80; + Inc(P); + Cnt := 64 - 1 - Cnt; + if Cnt < 8 then + begin + for n := 0 to cnt - 1 do + BufAnsiChar[P + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt, #0); + Transform(State, BufLong); + ArrLongToByte(BufLong, BufAnsiChar); + for n := 0 to 55 do + BufAnsiChar[n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar, 56, #0); + end + else + begin + for n := 0 to Cnt - 8 - 1 do + BufAnsiChar[p + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt - 8, #0); + end; + BufLong[14] := Count[0]; + BufLong[15] := Count[1]; + Transform(State, BufLong); + ArrLongToByte(State, Digest); +// Move(State, Digest, 16); + Result := ''; + for i := 0 to 15 do + Result := Result + Char(digest[i]); + end; +// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) +end; + +{==============================================================================} + +function MD5(const Value: String): String; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function HMAC_MD5(const Text: String; Key: String): String; +var + ipad, opad, s: String; + n: Integer; + MDContext: TMDCtx; +begin + if Length(Key) > 64 then + Key := md5(Key); + ipad := StringOfChar(HMAC_MD5_IPAD_CHAR, 64); + opad := StringOfChar(HMAC_MD5_OPAD_CHAR, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := Char(Byte(opad[n]) xor Byte(Key[n])); + end; + MDInit(MDContext); + MDUpdate(MDContext, ipad, @MD5Transform); + MDUpdate(MDContext, Text, @MD5Transform); + s := MDFinal(MDContext, @MD5Transform); + MDInit(MDContext); + MDUpdate(MDContext, opad, @MD5Transform); + MDUpdate(MDContext, s, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function MD5LongHash(const Value: String; Len: integer): String; +var + cnt, rest: integer; + l: integer; + n: integer; + MDContext: TMDCtx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + MDInit(MDContext); + for n := 1 to cnt do + MDUpdate(MDContext, Value, @MD5Transform); + if rest > 0 then + MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} +// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) + +procedure SHA1init( var SHA1Context: TSHA1Ctx ); +var + n: integer; +begin + SHA1Context.Hi := 0; + SHA1Context.Lo := 0; + SHA1Context.Index := 0; + for n := 0 to High(SHA1Context.Buffer) do + SHA1Context.Buffer[n] := 0; + for n := 0 to High(SHA1Context.HashByte) do + SHA1Context.HashByte[n] := 0; +// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); + SHA1Context.Hash[0] := integer($67452301); + SHA1Context.Hash[1] := integer($EFCDAB89); + SHA1Context.Hash[2] := integer($98BADCFE); + SHA1Context.Hash[3] := integer($10325476); + SHA1Context.Hash[4] := integer($C3D2E1F0); +end; + +//****************************************************************************** +function RB(A: integer): integer; +begin + Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); +end; + +procedure SHA1Compress(var Data: TSHA1Ctx); +var + A, B, C, D, E, T: integer; + W: array[0..79] of integer; + i: integer; + n: integer; + + function F1(x, y, z: integer): integer; + begin + Result := z xor (x and (y xor z)); + end; + function F2(x, y, z: integer): integer; + begin + Result := x xor y xor z; + end; + function F3(x, y, z: integer): integer; + begin + Result := (x and y) or (z and (x or y)); + end; + function LRot32(X: integer; c: integer): integer; + begin + result := (x shl c) or (x shr (32 - c)); + end; +begin + ArrByteToLong(Data.Buffer, W); +// Move(Data.Buffer, W, Sizeof(Data.Buffer)); + for i := 0 to 15 do + W[i] := RB(W[i]); + for i := 16 to 79 do + W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + for i := 0 to 19 do + begin + T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 20 to 39 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 40 to 59 do + begin + T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 60 to 79 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + Data.Hash[0] := Data.Hash[0] + A; + Data.Hash[1] := Data.Hash[1] + B; + Data.Hash[2] := Data.Hash[2] + C; + Data.Hash[3] := Data.Hash[3] + D; + Data.Hash[4] := Data.Hash[4] + E; + for n := 0 to high(w) do + w[n] := 0; +// FillChar(W, Sizeof(W), 0); + for n := 0 to high(Data.Buffer) do + Data.Buffer[n] := 0; +// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); +end; + +//****************************************************************************** +procedure SHA1Update(var Context: TSHA1Ctx; const Data: String); +var + Len: integer; + n: integer; + i, k: integer; +begin + Len := Length(data); + for k := 0 to 7 do + begin + i := Context.Lo; + Inc(Context.Lo, Len); + if Context.Lo < i then + Inc(Context.Hi); + end; + for n := 1 to len do + begin + Context.Buffer[Context.Index] := byte(Data[n]); + Inc(Context.Index); + if Context.Index = 64 then + begin + Context.Index := 0; + SHA1Compress(Context); + end; + end; +end; + +//****************************************************************************** +function SHA1Final(var Context: TSHA1Ctx): String; +type + Pinteger = ^integer; +var + i: integer; + procedure ItoArr(var Ar: Array of byte; I, value: Integer); + begin + Ar[i + 0] := Value and $000000FF; + Ar[i + 1] := (Value shr 8) and $000000FF; + Ar[i + 2] := (Value shr 16) and $000000FF; + Ar[i + 3] := (Value shr 24) and $000000FF; + end; +begin + Context.Buffer[Context.Index] := $80; + if Context.Index >= 56 then + SHA1Compress(Context); + ItoArr(Context.Buffer, 56, RB(Context.Hi)); + ItoArr(Context.Buffer, 60, RB(Context.Lo)); +// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); +// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); + SHA1Compress(Context); + Context.Hash[0] := RB(Context.Hash[0]); + Context.Hash[1] := RB(Context.Hash[1]); + Context.Hash[2] := RB(Context.Hash[2]); + Context.Hash[3] := RB(Context.Hash[3]); + Context.Hash[4] := RB(Context.Hash[4]); + ArrLongToByte(Context.Hash, Context.HashByte); + Result := ''; + for i := 0 to 19 do + Result := Result + Char(Context.HashByte[i]); +end; + +function SHA1(const Value: String): String; +var + SHA1Context: TSHA1Ctx; +begin + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, Value); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function HMAC_SHA1(const Text: String; Key: String): String; +var + ipad, opad, s: String; + n: Integer; + SHA1Context: TSHA1Ctx; +begin + if Length(Key) > 64 then + Key := SHA1(Key); + ipad := StringOfChar(HMAC_SHA1_IPAD_CHAR, 64); + opad := StringOfChar(HMAC_SHA1_OPAD_CHAR, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := Char(Byte(opad[n]) xor Byte(Key[n])); + end; + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, ipad); + SHA1Update(SHA1Context, Text); + s := SHA1Final(SHA1Context); + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, opad); + SHA1Update(SHA1Context, s); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function SHA1LongHash(const Value: String; Len: integer): String; +var + cnt, rest: integer; + l: integer; + n: integer; + SHA1Context: TSHA1Ctx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + SHA1Init(SHA1Context); + for n := 1 to cnt do + SHA1Update(SHA1Context, Value); + if rest > 0 then + SHA1Update(SHA1Context, Copy(Value, 1, rest)); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + function LRot32(a, b: longint): longint; + begin + Result:= (a shl b) or (a shr (32 - b)); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); + + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); + + A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +{==============================================================================} + +function MD4(const Value: String): String; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD4Transform); + Result := MDFinal(MDContext, @MD4Transform); +end; + +{==============================================================================} + + +end. diff --git a/synacrypt.pas b/synacrypt.pas new file mode 100644 index 0000000..4eb3849 --- /dev/null +++ b/synacrypt.pas @@ -0,0 +1,2412 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.000 | +|==============================================================================| +| Content: Encryption support | +|==============================================================================| +| Copyright (c)2007-2011, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2007-2011. | +| All Rights Reserved. | +| Based on work of David Barton and Eric Young | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Encryption support) + +Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit, + CFB-block, OFB and CTR methods. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synacrypt; + +interface + +uses + SysUtils, Classes, synautil, synafpc; + +type + {:@abstract(Implementation of common routines block ciphers (dafault size is 64-bits)) + + Do not use this class directly, use descendants only!} + TSynaBlockCipher= class(TObject) + protected + procedure InitKey(Key: AnsiString); virtual; + function GetSize: byte; virtual; + private + IV, CV: AnsiString; + procedure IncCounter; + public + {:Sets the IV to Value and performs a reset} + procedure SetIV(const Value: AnsiString); virtual; + {:Returns the current chaining information, not the actual IV} + function GetIV: AnsiString; virtual; + {:Reset any stored chaining information} + procedure Reset; virtual; + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; virtual; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; virtual; + {:Encrypt data using the CBC method of encryption} + function EncryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CBC method of decryption} + function DecryptCBC(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (8 bit) method of encryption} + function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (8 bit) method of decryption} + function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CFB (block) method of encryption} + function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CFB (block) method of decryption} + function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the OFB method of encryption} + function EncryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the OFB method of decryption} + function DecryptOFB(const Indata: AnsiString): AnsiString; virtual; + {:Encrypt data using the CTR method of encryption} + function EncryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Decrypt data using the CTR method of decryption} + function DecryptCTR(const Indata: AnsiString): AnsiString; virtual; + {:Create a encryptor/decryptor instance and initialize it by the Key.} + constructor Create(Key: AnsiString); + end; + + {:@abstract(Datatype for holding one DES key data) + + This data type is used internally.} + TDesKeyData = array[0..31] of integer; + + {:@abstract(Implementation of common routines for DES encryption) + + Do not use this class directly, use descendants only!} + TSynaCustomDes = class(TSynaBlockcipher) + protected + procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); + function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; + end; + + {:@abstract(Implementation of DES encryption)} + TSynaDes= class(TSynaCustomDes) + protected + KeyData: TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + + {:@abstract(Implementation of 3DES encryption)} + TSyna3Des= class(TSynaCustomDes) + protected + KeyData: array[0..2] of TDesKeyData; + procedure InitKey(Key: AnsiString); override; + public + {:Encrypt a 64-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 64-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + +const + BC = 4; + MAXROUNDS = 14; +type + {:@abstract(Implementation of AES encryption)} + TSynaAes= class(TSynaBlockcipher) + protected + numrounds: longword; + rk, drk: array[0..MAXROUNDS,0..7] of longword; + procedure InitKey(Key: AnsiString); override; + function GetSize: byte; override; + public + {:Encrypt a 128-bit block of data using the ECB method of encryption} + function EncryptECB(const InData: AnsiString): AnsiString; override; + {:Decrypt a 128-bit block of data using the ECB method of decryption} + function DecryptECB(const InData: AnsiString): AnsiString; override; + end; + +{:Call internal test of all DES encryptions. Returns @true if all is OK.} +function TestDes: boolean; +{:Call internal test of all 3DES encryptions. Returns @true if all is OK.} +function Test3Des: boolean; +{:Call internal test of all AES encryptions. Returns @true if all is OK.} +function TestAes: boolean; + +{==============================================================================} +implementation + +//DES consts +const + shifts2: array[0..15]of byte= + (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); + + des_skb: array[0..7,0..63]of integer=( + ( + (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($00000010),integer($20000000),integer($20000010), + integer($00010000),integer($00010010),integer($20010000),integer($20010010), + integer($00000800),integer($00000810),integer($20000800),integer($20000810), + integer($00010800),integer($00010810),integer($20010800),integer($20010810), + integer($00000020),integer($00000030),integer($20000020),integer($20000030), + integer($00010020),integer($00010030),integer($20010020),integer($20010030), + integer($00000820),integer($00000830),integer($20000820),integer($20000830), + integer($00010820),integer($00010830),integer($20010820),integer($20010830), + integer($00080000),integer($00080010),integer($20080000),integer($20080010), + integer($00090000),integer($00090010),integer($20090000),integer($20090010), + integer($00080800),integer($00080810),integer($20080800),integer($20080810), + integer($00090800),integer($00090810),integer($20090800),integer($20090810), + integer($00080020),integer($00080030),integer($20080020),integer($20080030), + integer($00090020),integer($00090030),integer($20090020),integer($20090030), + integer($00080820),integer($00080830),integer($20080820),integer($20080830), + integer($00090820),integer($00090830),integer($20090820),integer($20090830) + ),( + (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) + integer($00000000),integer($02000000),integer($00002000),integer($02002000), + integer($00200000),integer($02200000),integer($00202000),integer($02202000), + integer($00000004),integer($02000004),integer($00002004),integer($02002004), + integer($00200004),integer($02200004),integer($00202004),integer($02202004), + integer($00000400),integer($02000400),integer($00002400),integer($02002400), + integer($00200400),integer($02200400),integer($00202400),integer($02202400), + integer($00000404),integer($02000404),integer($00002404),integer($02002404), + integer($00200404),integer($02200404),integer($00202404),integer($02202404), + integer($10000000),integer($12000000),integer($10002000),integer($12002000), + integer($10200000),integer($12200000),integer($10202000),integer($12202000), + integer($10000004),integer($12000004),integer($10002004),integer($12002004), + integer($10200004),integer($12200004),integer($10202004),integer($12202004), + integer($10000400),integer($12000400),integer($10002400),integer($12002400), + integer($10200400),integer($12200400),integer($10202400),integer($12202400), + integer($10000404),integer($12000404),integer($10002404),integer($12002404), + integer($10200404),integer($12200404),integer($10202404),integer($12202404) + ),( + (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) + integer($00000000),integer($00000001),integer($00040000),integer($00040001), + integer($01000000),integer($01000001),integer($01040000),integer($01040001), + integer($00000002),integer($00000003),integer($00040002),integer($00040003), + integer($01000002),integer($01000003),integer($01040002),integer($01040003), + integer($00000200),integer($00000201),integer($00040200),integer($00040201), + integer($01000200),integer($01000201),integer($01040200),integer($01040201), + integer($00000202),integer($00000203),integer($00040202),integer($00040203), + integer($01000202),integer($01000203),integer($01040202),integer($01040203), + integer($08000000),integer($08000001),integer($08040000),integer($08040001), + integer($09000000),integer($09000001),integer($09040000),integer($09040001), + integer($08000002),integer($08000003),integer($08040002),integer($08040003), + integer($09000002),integer($09000003),integer($09040002),integer($09040003), + integer($08000200),integer($08000201),integer($08040200),integer($08040201), + integer($09000200),integer($09000201),integer($09040200),integer($09040201), + integer($08000202),integer($08000203),integer($08040202),integer($08040203), + integer($09000202),integer($09000203),integer($09040202),integer($09040203) + ),( + (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) + integer($00000000),integer($00100000),integer($00000100),integer($00100100), + integer($00000008),integer($00100008),integer($00000108),integer($00100108), + integer($00001000),integer($00101000),integer($00001100),integer($00101100), + integer($00001008),integer($00101008),integer($00001108),integer($00101108), + integer($04000000),integer($04100000),integer($04000100),integer($04100100), + integer($04000008),integer($04100008),integer($04000108),integer($04100108), + integer($04001000),integer($04101000),integer($04001100),integer($04101100), + integer($04001008),integer($04101008),integer($04001108),integer($04101108), + integer($00020000),integer($00120000),integer($00020100),integer($00120100), + integer($00020008),integer($00120008),integer($00020108),integer($00120108), + integer($00021000),integer($00121000),integer($00021100),integer($00121100), + integer($00021008),integer($00121008),integer($00021108),integer($00121108), + integer($04020000),integer($04120000),integer($04020100),integer($04120100), + integer($04020008),integer($04120008),integer($04020108),integer($04120108), + integer($04021000),integer($04121000),integer($04021100),integer($04121100), + integer($04021008),integer($04121008),integer($04021108),integer($04121108) + ),( + (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) + integer($00000000),integer($10000000),integer($00010000),integer($10010000), + integer($00000004),integer($10000004),integer($00010004),integer($10010004), + integer($20000000),integer($30000000),integer($20010000),integer($30010000), + integer($20000004),integer($30000004),integer($20010004),integer($30010004), + integer($00100000),integer($10100000),integer($00110000),integer($10110000), + integer($00100004),integer($10100004),integer($00110004),integer($10110004), + integer($20100000),integer($30100000),integer($20110000),integer($30110000), + integer($20100004),integer($30100004),integer($20110004),integer($30110004), + integer($00001000),integer($10001000),integer($00011000),integer($10011000), + integer($00001004),integer($10001004),integer($00011004),integer($10011004), + integer($20001000),integer($30001000),integer($20011000),integer($30011000), + integer($20001004),integer($30001004),integer($20011004),integer($30011004), + integer($00101000),integer($10101000),integer($00111000),integer($10111000), + integer($00101004),integer($10101004),integer($00111004),integer($10111004), + integer($20101000),integer($30101000),integer($20111000),integer($30111000), + integer($20101004),integer($30101004),integer($20111004),integer($30111004) + ),( + (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) + integer($00000000),integer($08000000),integer($00000008),integer($08000008), + integer($00000400),integer($08000400),integer($00000408),integer($08000408), + integer($00020000),integer($08020000),integer($00020008),integer($08020008), + integer($00020400),integer($08020400),integer($00020408),integer($08020408), + integer($00000001),integer($08000001),integer($00000009),integer($08000009), + integer($00000401),integer($08000401),integer($00000409),integer($08000409), + integer($00020001),integer($08020001),integer($00020009),integer($08020009), + integer($00020401),integer($08020401),integer($00020409),integer($08020409), + integer($02000000),integer($0A000000),integer($02000008),integer($0A000008), + integer($02000400),integer($0A000400),integer($02000408),integer($0A000408), + integer($02020000),integer($0A020000),integer($02020008),integer($0A020008), + integer($02020400),integer($0A020400),integer($02020408),integer($0A020408), + integer($02000001),integer($0A000001),integer($02000009),integer($0A000009), + integer($02000401),integer($0A000401),integer($02000409),integer($0A000409), + integer($02020001),integer($0A020001),integer($02020009),integer($0A020009), + integer($02020401),integer($0A020401),integer($02020409),integer($0A020409) + ),( + (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) + integer($00000000),integer($00000100),integer($00080000),integer($00080100), + integer($01000000),integer($01000100),integer($01080000),integer($01080100), + integer($00000010),integer($00000110),integer($00080010),integer($00080110), + integer($01000010),integer($01000110),integer($01080010),integer($01080110), + integer($00200000),integer($00200100),integer($00280000),integer($00280100), + integer($01200000),integer($01200100),integer($01280000),integer($01280100), + integer($00200010),integer($00200110),integer($00280010),integer($00280110), + integer($01200010),integer($01200110),integer($01280010),integer($01280110), + integer($00000200),integer($00000300),integer($00080200),integer($00080300), + integer($01000200),integer($01000300),integer($01080200),integer($01080300), + integer($00000210),integer($00000310),integer($00080210),integer($00080310), + integer($01000210),integer($01000310),integer($01080210),integer($01080310), + integer($00200200),integer($00200300),integer($00280200),integer($00280300), + integer($01200200),integer($01200300),integer($01280200),integer($01280300), + integer($00200210),integer($00200310),integer($00280210),integer($00280310), + integer($01200210),integer($01200310),integer($01280210),integer($01280310) + ),( + (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) + integer($00000000),integer($04000000),integer($00040000),integer($04040000), + integer($00000002),integer($04000002),integer($00040002),integer($04040002), + integer($00002000),integer($04002000),integer($00042000),integer($04042000), + integer($00002002),integer($04002002),integer($00042002),integer($04042002), + integer($00000020),integer($04000020),integer($00040020),integer($04040020), + integer($00000022),integer($04000022),integer($00040022),integer($04040022), + integer($00002020),integer($04002020),integer($00042020),integer($04042020), + integer($00002022),integer($04002022),integer($00042022),integer($04042022), + integer($00000800),integer($04000800),integer($00040800),integer($04040800), + integer($00000802),integer($04000802),integer($00040802),integer($04040802), + integer($00002800),integer($04002800),integer($00042800),integer($04042800), + integer($00002802),integer($04002802),integer($00042802),integer($04042802), + integer($00000820),integer($04000820),integer($00040820),integer($04040820), + integer($00000822),integer($04000822),integer($00040822),integer($04040822), + integer($00002820),integer($04002820),integer($00042820),integer($04042820), + integer($00002822),integer($04002822),integer($00042822),integer($04042822) + )); + + des_sptrans: array[0..7,0..63] of integer=( + ( + (* nibble 0 *) + integer($02080800), integer($00080000), integer($02000002), integer($02080802), + integer($02000000), integer($00080802), integer($00080002), integer($02000002), + integer($00080802), integer($02080800), integer($02080000), integer($00000802), + integer($02000802), integer($02000000), integer($00000000), integer($00080002), + integer($00080000), integer($00000002), integer($02000800), integer($00080800), + integer($02080802), integer($02080000), integer($00000802), integer($02000800), + integer($00000002), integer($00000800), integer($00080800), integer($02080002), + integer($00000800), integer($02000802), integer($02080002), integer($00000000), + integer($00000000), integer($02080802), integer($02000800), integer($00080002), + integer($02080800), integer($00080000), integer($00000802), integer($02000800), + integer($02080002), integer($00000800), integer($00080800), integer($02000002), + integer($00080802), integer($00000002), integer($02000002), integer($02080000), + integer($02080802), integer($00080800), integer($02080000), integer($02000802), + integer($02000000), integer($00000802), integer($00080002), integer($00000000), + integer($00080000), integer($02000000), integer($02000802), integer($02080800), + integer($00000002), integer($02080002), integer($00000800), integer($00080802) + ),( + (* nibble 1 *) + integer($40108010), integer($00000000), integer($00108000), integer($40100000), + integer($40000010), integer($00008010), integer($40008000), integer($00108000), + integer($00008000), integer($40100010), integer($00000010), integer($40008000), + integer($00100010), integer($40108000), integer($40100000), integer($00000010), + integer($00100000), integer($40008010), integer($40100010), integer($00008000), + integer($00108010), integer($40000000), integer($00000000), integer($00100010), + integer($40008010), integer($00108010), integer($40108000), integer($40000010), + integer($40000000), integer($00100000), integer($00008010), integer($40108010), + integer($00100010), integer($40108000), integer($40008000), integer($00108010), + integer($40108010), integer($00100010), integer($40000010), integer($00000000), + integer($40000000), integer($00008010), integer($00100000), integer($40100010), + integer($00008000), integer($40000000), integer($00108010), integer($40008010), + integer($40108000), integer($00008000), integer($00000000), integer($40000010), + integer($00000010), integer($40108010), integer($00108000), integer($40100000), + integer($40100010), integer($00100000), integer($00008010), integer($40008000), + integer($40008010), integer($00000010), integer($40100000), integer($00108000) + ),( + (* nibble 2 *) + integer($04000001), integer($04040100), integer($00000100), integer($04000101), + integer($00040001), integer($04000000), integer($04000101), integer($00040100), + integer($04000100), integer($00040000), integer($04040000), integer($00000001), + integer($04040101), integer($00000101), integer($00000001), integer($04040001), + integer($00000000), integer($00040001), integer($04040100), integer($00000100), + integer($00000101), integer($04040101), integer($00040000), integer($04000001), + integer($04040001), integer($04000100), integer($00040101), integer($04040000), + integer($00040100), integer($00000000), integer($04000000), integer($00040101), + integer($04040100), integer($00000100), integer($00000001), integer($00040000), + integer($00000101), integer($00040001), integer($04040000), integer($04000101), + integer($00000000), integer($04040100), integer($00040100), integer($04040001), + integer($00040001), integer($04000000), integer($04040101), integer($00000001), + integer($00040101), integer($04000001), integer($04000000), integer($04040101), + integer($00040000), integer($04000100), integer($04000101), integer($00040100), + integer($04000100), integer($00000000), integer($04040001), integer($00000101), + integer($04000001), integer($00040101), integer($00000100), integer($04040000) + ),( + (* nibble 3 *) + integer($00401008), integer($10001000), integer($00000008), integer($10401008), + integer($00000000), integer($10400000), integer($10001008), integer($00400008), + integer($10401000), integer($10000008), integer($10000000), integer($00001008), + integer($10000008), integer($00401008), integer($00400000), integer($10000000), + integer($10400008), integer($00401000), integer($00001000), integer($00000008), + integer($00401000), integer($10001008), integer($10400000), integer($00001000), + integer($00001008), integer($00000000), integer($00400008), integer($10401000), + integer($10001000), integer($10400008), integer($10401008), integer($00400000), + integer($10400008), integer($00001008), integer($00400000), integer($10000008), + integer($00401000), integer($10001000), integer($00000008), integer($10400000), + integer($10001008), integer($00000000), integer($00001000), integer($00400008), + integer($00000000), integer($10400008), integer($10401000), integer($00001000), + integer($10000000), integer($10401008), integer($00401008), integer($00400000), + integer($10401008), integer($00000008), integer($10001000), integer($00401008), + integer($00400008), integer($00401000), integer($10400000), integer($10001008), + integer($00001008), integer($10000000), integer($10000008), integer($10401000) + ),( + (* nibble 4 *) + integer($08000000), integer($00010000), integer($00000400), integer($08010420), + integer($08010020), integer($08000400), integer($00010420), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($00010400), + integer($08000420), integer($08010020), integer($08010400), integer($00000000), + integer($00010400), integer($08000000), integer($00010020), integer($00000420), + integer($08000400), integer($00010420), integer($00000000), integer($08000020), + integer($00000020), integer($08000420), integer($08010420), integer($00010020), + integer($08010000), integer($00000400), integer($00000420), integer($08010400), + integer($08010400), integer($08000420), integer($00010020), integer($08010000), + integer($00010000), integer($00000020), integer($08000020), integer($08000400), + integer($08000000), integer($00010400), integer($08010420), integer($00000000), + integer($00010420), integer($08000000), integer($00000400), integer($00010020), + integer($08000420), integer($00000400), integer($00000000), integer($08010420), + integer($08010020), integer($08010400), integer($00000420), integer($00010000), + integer($00010400), integer($08010020), integer($08000400), integer($00000420), + integer($00000020), integer($00010420), integer($08010000), integer($08000020) + ),( + (* nibble 5 *) + integer($80000040), integer($00200040), integer($00000000), integer($80202000), + integer($00200040), integer($00002000), integer($80002040), integer($00200000), + integer($00002040), integer($80202040), integer($00202000), integer($80000000), + integer($80002000), integer($80000040), integer($80200000), integer($00202040), + integer($00200000), integer($80002040), integer($80200040), integer($00000000), + integer($00002000), integer($00000040), integer($80202000), integer($80200040), + integer($80202040), integer($80200000), integer($80000000), integer($00002040), + integer($00000040), integer($00202000), integer($00202040), integer($80002000), + integer($00002040), integer($80000000), integer($80002000), integer($00202040), + integer($80202000), integer($00200040), integer($00000000), integer($80002000), + integer($80000000), integer($00002000), integer($80200040), integer($00200000), + integer($00200040), integer($80202040), integer($00202000), integer($00000040), + integer($80202040), integer($00202000), integer($00200000), integer($80002040), + integer($80000040), integer($80200000), integer($00202040), integer($00000000), + integer($00002000), integer($80000040), integer($80002040), integer($80202000), + integer($80200000), integer($00002040), integer($00000040), integer($80200040) + ),( + (* nibble 6 *) + integer($00004000), integer($00000200), integer($01000200), integer($01000004), + integer($01004204), integer($00004004), integer($00004200), integer($00000000), + integer($01000000), integer($01000204), integer($00000204), integer($01004000), + integer($00000004), integer($01004200), integer($01004000), integer($00000204), + integer($01000204), integer($00004000), integer($00004004), integer($01004204), + integer($00000000), integer($01000200), integer($01000004), integer($00004200), + integer($01004004), integer($00004204), integer($01004200), integer($00000004), + integer($00004204), integer($01004004), integer($00000200), integer($01000000), + integer($00004204), integer($01004000), integer($01004004), integer($00000204), + integer($00004000), integer($00000200), integer($01000000), integer($01004004), + integer($01000204), integer($00004204), integer($00004200), integer($00000000), + integer($00000200), integer($01000004), integer($00000004), integer($01000200), + integer($00000000), integer($01000204), integer($01000200), integer($00004200), + integer($00000204), integer($00004000), integer($01004204), integer($01000000), + integer($01004200), integer($00000004), integer($00004004), integer($01004204), + integer($01000004), integer($01004200), integer($01004000), integer($00004004) + ),( + (* nibble 7 *) + integer($20800080), integer($20820000), integer($00020080), integer($00000000), + integer($20020000), integer($00800080), integer($20800000), integer($20820080), + integer($00000080), integer($20000000), integer($00820000), integer($00020080), + integer($00820080), integer($20020080), integer($20000080), integer($20800000), + integer($00020000), integer($00820080), integer($00800080), integer($20020000), + integer($20820080), integer($20000080), integer($00000000), integer($00820000), + integer($20000000), integer($00800000), integer($20020080), integer($20800080), + integer($00800000), integer($00020000), integer($20820000), integer($00000080), + integer($00800000), integer($00020000), integer($20000080), integer($20820080), + integer($00020080), integer($20000000), integer($00000000), integer($00820000), + integer($20800080), integer($20020080), integer($20020000), integer($00800080), + integer($20820000), integer($00000080), integer($00800080), integer($20020000), + integer($20820080), integer($00800000), integer($20800000), integer($20000080), + integer($00820000), integer($00020080), integer($20020080), integer($20800000), + integer($00000080), integer($20820000), integer($00820080), integer($00000000), + integer($20000000), integer($20800080), integer($00020000), integer($00820080) + )); + +//AES consts +const + MAXBC= 8; + MAXKC= 8; + + S: array[0..255] of byte= ( + 99, 124, 119, 123, 242, 107, 111, 197, 48, 1, 103, 43, 254, 215, 171, 118, + 202, 130, 201, 125, 250, 89, 71, 240, 173, 212, 162, 175, 156, 164, 114, 192, + 183, 253, 147, 38, 54, 63, 247, 204, 52, 165, 229, 241, 113, 216, 49, 21, + 4, 199, 35, 195, 24, 150, 5, 154, 7, 18, 128, 226, 235, 39, 178, 117, + 9, 131, 44, 26, 27, 110, 90, 160, 82, 59, 214, 179, 41, 227, 47, 132, + 83, 209, 0, 237, 32, 252, 177, 91, 106, 203, 190, 57, 74, 76, 88, 207, + 208, 239, 170, 251, 67, 77, 51, 133, 69, 249, 2, 127, 80, 60, 159, 168, + 81, 163, 64, 143, 146, 157, 56, 245, 188, 182, 218, 33, 16, 255, 243, 210, + 205, 12, 19, 236, 95, 151, 68, 23, 196, 167, 126, 61, 100, 93, 25, 115, + 96, 129, 79, 220, 34, 42, 144, 136, 70, 238, 184, 20, 222, 94, 11, 219, + 224, 50, 58, 10, 73, 6, 36, 92, 194, 211, 172, 98, 145, 149, 228, 121, + 231, 200, 55, 109, 141, 213, 78, 169, 108, 86, 244, 234, 101, 122, 174, 8, + 186, 120, 37, 46, 28, 166, 180, 198, 232, 221, 116, 31, 75, 189, 139, 138, + 112, 62, 181, 102, 72, 3, 246, 14, 97, 53, 87, 185, 134, 193, 29, 158, + 225, 248, 152, 17, 105, 217, 142, 148, 155, 30, 135, 233, 206, 85, 40, 223, + 140, 161, 137, 13, 191, 230, 66, 104, 65, 153, 45, 15, 176, 84, 187, 22); + T1: array[0..255,0..3] of byte= ( + ($c6,$63,$63,$a5), ($f8,$7c,$7c,$84), ($ee,$77,$77,$99), ($f6,$7b,$7b,$8d), + ($ff,$f2,$f2,$0d), ($d6,$6b,$6b,$bd), ($de,$6f,$6f,$b1), ($91,$c5,$c5,$54), + ($60,$30,$30,$50), ($02,$01,$01,$03), ($ce,$67,$67,$a9), ($56,$2b,$2b,$7d), + ($e7,$fe,$fe,$19), ($b5,$d7,$d7,$62), ($4d,$ab,$ab,$e6), ($ec,$76,$76,$9a), + ($8f,$ca,$ca,$45), ($1f,$82,$82,$9d), ($89,$c9,$c9,$40), ($fa,$7d,$7d,$87), + ($ef,$fa,$fa,$15), ($b2,$59,$59,$eb), ($8e,$47,$47,$c9), ($fb,$f0,$f0,$0b), + ($41,$ad,$ad,$ec), ($b3,$d4,$d4,$67), ($5f,$a2,$a2,$fd), ($45,$af,$af,$ea), + ($23,$9c,$9c,$bf), ($53,$a4,$a4,$f7), ($e4,$72,$72,$96), ($9b,$c0,$c0,$5b), + ($75,$b7,$b7,$c2), ($e1,$fd,$fd,$1c), ($3d,$93,$93,$ae), ($4c,$26,$26,$6a), + ($6c,$36,$36,$5a), ($7e,$3f,$3f,$41), ($f5,$f7,$f7,$02), ($83,$cc,$cc,$4f), + ($68,$34,$34,$5c), ($51,$a5,$a5,$f4), ($d1,$e5,$e5,$34), ($f9,$f1,$f1,$08), + ($e2,$71,$71,$93), ($ab,$d8,$d8,$73), ($62,$31,$31,$53), ($2a,$15,$15,$3f), + ($08,$04,$04,$0c), ($95,$c7,$c7,$52), ($46,$23,$23,$65), ($9d,$c3,$c3,$5e), + ($30,$18,$18,$28), ($37,$96,$96,$a1), ($0a,$05,$05,$0f), ($2f,$9a,$9a,$b5), + ($0e,$07,$07,$09), ($24,$12,$12,$36), ($1b,$80,$80,$9b), ($df,$e2,$e2,$3d), + ($cd,$eb,$eb,$26), ($4e,$27,$27,$69), ($7f,$b2,$b2,$cd), ($ea,$75,$75,$9f), + ($12,$09,$09,$1b), ($1d,$83,$83,$9e), ($58,$2c,$2c,$74), ($34,$1a,$1a,$2e), + ($36,$1b,$1b,$2d), ($dc,$6e,$6e,$b2), ($b4,$5a,$5a,$ee), ($5b,$a0,$a0,$fb), + ($a4,$52,$52,$f6), ($76,$3b,$3b,$4d), ($b7,$d6,$d6,$61), ($7d,$b3,$b3,$ce), + ($52,$29,$29,$7b), ($dd,$e3,$e3,$3e), ($5e,$2f,$2f,$71), ($13,$84,$84,$97), + ($a6,$53,$53,$f5), ($b9,$d1,$d1,$68), ($00,$00,$00,$00), ($c1,$ed,$ed,$2c), + ($40,$20,$20,$60), ($e3,$fc,$fc,$1f), ($79,$b1,$b1,$c8), ($b6,$5b,$5b,$ed), + ($d4,$6a,$6a,$be), ($8d,$cb,$cb,$46), ($67,$be,$be,$d9), ($72,$39,$39,$4b), + ($94,$4a,$4a,$de), ($98,$4c,$4c,$d4), ($b0,$58,$58,$e8), ($85,$cf,$cf,$4a), + ($bb,$d0,$d0,$6b), ($c5,$ef,$ef,$2a), ($4f,$aa,$aa,$e5), ($ed,$fb,$fb,$16), + ($86,$43,$43,$c5), ($9a,$4d,$4d,$d7), ($66,$33,$33,$55), ($11,$85,$85,$94), + ($8a,$45,$45,$cf), ($e9,$f9,$f9,$10), ($04,$02,$02,$06), ($fe,$7f,$7f,$81), + ($a0,$50,$50,$f0), ($78,$3c,$3c,$44), ($25,$9f,$9f,$ba), ($4b,$a8,$a8,$e3), + ($a2,$51,$51,$f3), ($5d,$a3,$a3,$fe), ($80,$40,$40,$c0), ($05,$8f,$8f,$8a), + ($3f,$92,$92,$ad), ($21,$9d,$9d,$bc), ($70,$38,$38,$48), ($f1,$f5,$f5,$04), + ($63,$bc,$bc,$df), ($77,$b6,$b6,$c1), ($af,$da,$da,$75), ($42,$21,$21,$63), + ($20,$10,$10,$30), ($e5,$ff,$ff,$1a), ($fd,$f3,$f3,$0e), ($bf,$d2,$d2,$6d), + ($81,$cd,$cd,$4c), ($18,$0c,$0c,$14), ($26,$13,$13,$35), ($c3,$ec,$ec,$2f), + ($be,$5f,$5f,$e1), ($35,$97,$97,$a2), ($88,$44,$44,$cc), ($2e,$17,$17,$39), + ($93,$c4,$c4,$57), ($55,$a7,$a7,$f2), ($fc,$7e,$7e,$82), ($7a,$3d,$3d,$47), + ($c8,$64,$64,$ac), ($ba,$5d,$5d,$e7), ($32,$19,$19,$2b), ($e6,$73,$73,$95), + ($c0,$60,$60,$a0), ($19,$81,$81,$98), ($9e,$4f,$4f,$d1), ($a3,$dc,$dc,$7f), + ($44,$22,$22,$66), ($54,$2a,$2a,$7e), ($3b,$90,$90,$ab), ($0b,$88,$88,$83), + ($8c,$46,$46,$ca), ($c7,$ee,$ee,$29), ($6b,$b8,$b8,$d3), ($28,$14,$14,$3c), + ($a7,$de,$de,$79), ($bc,$5e,$5e,$e2), ($16,$0b,$0b,$1d), ($ad,$db,$db,$76), + ($db,$e0,$e0,$3b), ($64,$32,$32,$56), ($74,$3a,$3a,$4e), ($14,$0a,$0a,$1e), + ($92,$49,$49,$db), ($0c,$06,$06,$0a), ($48,$24,$24,$6c), ($b8,$5c,$5c,$e4), + ($9f,$c2,$c2,$5d), ($bd,$d3,$d3,$6e), ($43,$ac,$ac,$ef), ($c4,$62,$62,$a6), + ($39,$91,$91,$a8), ($31,$95,$95,$a4), ($d3,$e4,$e4,$37), ($f2,$79,$79,$8b), + ($d5,$e7,$e7,$32), ($8b,$c8,$c8,$43), ($6e,$37,$37,$59), ($da,$6d,$6d,$b7), + ($01,$8d,$8d,$8c), ($b1,$d5,$d5,$64), ($9c,$4e,$4e,$d2), ($49,$a9,$a9,$e0), + ($d8,$6c,$6c,$b4), ($ac,$56,$56,$fa), ($f3,$f4,$f4,$07), ($cf,$ea,$ea,$25), + ($ca,$65,$65,$af), ($f4,$7a,$7a,$8e), ($47,$ae,$ae,$e9), ($10,$08,$08,$18), + ($6f,$ba,$ba,$d5), ($f0,$78,$78,$88), ($4a,$25,$25,$6f), ($5c,$2e,$2e,$72), + ($38,$1c,$1c,$24), ($57,$a6,$a6,$f1), ($73,$b4,$b4,$c7), ($97,$c6,$c6,$51), + ($cb,$e8,$e8,$23), ($a1,$dd,$dd,$7c), ($e8,$74,$74,$9c), ($3e,$1f,$1f,$21), + ($96,$4b,$4b,$dd), ($61,$bd,$bd,$dc), ($0d,$8b,$8b,$86), ($0f,$8a,$8a,$85), + ($e0,$70,$70,$90), ($7c,$3e,$3e,$42), ($71,$b5,$b5,$c4), ($cc,$66,$66,$aa), + ($90,$48,$48,$d8), ($06,$03,$03,$05), ($f7,$f6,$f6,$01), ($1c,$0e,$0e,$12), + ($c2,$61,$61,$a3), ($6a,$35,$35,$5f), ($ae,$57,$57,$f9), ($69,$b9,$b9,$d0), + ($17,$86,$86,$91), ($99,$c1,$c1,$58), ($3a,$1d,$1d,$27), ($27,$9e,$9e,$b9), + ($d9,$e1,$e1,$38), ($eb,$f8,$f8,$13), ($2b,$98,$98,$b3), ($22,$11,$11,$33), + ($d2,$69,$69,$bb), ($a9,$d9,$d9,$70), ($07,$8e,$8e,$89), ($33,$94,$94,$a7), + ($2d,$9b,$9b,$b6), ($3c,$1e,$1e,$22), ($15,$87,$87,$92), ($c9,$e9,$e9,$20), + ($87,$ce,$ce,$49), ($aa,$55,$55,$ff), ($50,$28,$28,$78), ($a5,$df,$df,$7a), + ($03,$8c,$8c,$8f), ($59,$a1,$a1,$f8), ($09,$89,$89,$80), ($1a,$0d,$0d,$17), + ($65,$bf,$bf,$da), ($d7,$e6,$e6,$31), ($84,$42,$42,$c6), ($d0,$68,$68,$b8), + ($82,$41,$41,$c3), ($29,$99,$99,$b0), ($5a,$2d,$2d,$77), ($1e,$0f,$0f,$11), + ($7b,$b0,$b0,$cb), ($a8,$54,$54,$fc), ($6d,$bb,$bb,$d6), ($2c,$16,$16,$3a)); + T2: array[0..255,0..3] of byte= ( + ($a5,$c6,$63,$63), ($84,$f8,$7c,$7c), ($99,$ee,$77,$77), ($8d,$f6,$7b,$7b), + ($0d,$ff,$f2,$f2), ($bd,$d6,$6b,$6b), ($b1,$de,$6f,$6f), ($54,$91,$c5,$c5), + ($50,$60,$30,$30), ($03,$02,$01,$01), ($a9,$ce,$67,$67), ($7d,$56,$2b,$2b), + ($19,$e7,$fe,$fe), ($62,$b5,$d7,$d7), ($e6,$4d,$ab,$ab), ($9a,$ec,$76,$76), + ($45,$8f,$ca,$ca), ($9d,$1f,$82,$82), ($40,$89,$c9,$c9), ($87,$fa,$7d,$7d), + ($15,$ef,$fa,$fa), ($eb,$b2,$59,$59), ($c9,$8e,$47,$47), ($0b,$fb,$f0,$f0), + ($ec,$41,$ad,$ad), ($67,$b3,$d4,$d4), ($fd,$5f,$a2,$a2), ($ea,$45,$af,$af), + ($bf,$23,$9c,$9c), ($f7,$53,$a4,$a4), ($96,$e4,$72,$72), ($5b,$9b,$c0,$c0), + ($c2,$75,$b7,$b7), ($1c,$e1,$fd,$fd), ($ae,$3d,$93,$93), ($6a,$4c,$26,$26), + ($5a,$6c,$36,$36), ($41,$7e,$3f,$3f), ($02,$f5,$f7,$f7), ($4f,$83,$cc,$cc), + ($5c,$68,$34,$34), ($f4,$51,$a5,$a5), ($34,$d1,$e5,$e5), ($08,$f9,$f1,$f1), + ($93,$e2,$71,$71), ($73,$ab,$d8,$d8), ($53,$62,$31,$31), ($3f,$2a,$15,$15), + ($0c,$08,$04,$04), ($52,$95,$c7,$c7), ($65,$46,$23,$23), ($5e,$9d,$c3,$c3), + ($28,$30,$18,$18), ($a1,$37,$96,$96), ($0f,$0a,$05,$05), ($b5,$2f,$9a,$9a), + ($09,$0e,$07,$07), ($36,$24,$12,$12), ($9b,$1b,$80,$80), ($3d,$df,$e2,$e2), + ($26,$cd,$eb,$eb), ($69,$4e,$27,$27), ($cd,$7f,$b2,$b2), ($9f,$ea,$75,$75), + ($1b,$12,$09,$09), ($9e,$1d,$83,$83), ($74,$58,$2c,$2c), ($2e,$34,$1a,$1a), + ($2d,$36,$1b,$1b), ($b2,$dc,$6e,$6e), ($ee,$b4,$5a,$5a), ($fb,$5b,$a0,$a0), + ($f6,$a4,$52,$52), ($4d,$76,$3b,$3b), ($61,$b7,$d6,$d6), ($ce,$7d,$b3,$b3), + ($7b,$52,$29,$29), ($3e,$dd,$e3,$e3), ($71,$5e,$2f,$2f), ($97,$13,$84,$84), + ($f5,$a6,$53,$53), ($68,$b9,$d1,$d1), ($00,$00,$00,$00), ($2c,$c1,$ed,$ed), + ($60,$40,$20,$20), ($1f,$e3,$fc,$fc), ($c8,$79,$b1,$b1), ($ed,$b6,$5b,$5b), + ($be,$d4,$6a,$6a), ($46,$8d,$cb,$cb), ($d9,$67,$be,$be), ($4b,$72,$39,$39), + ($de,$94,$4a,$4a), ($d4,$98,$4c,$4c), ($e8,$b0,$58,$58), ($4a,$85,$cf,$cf), + ($6b,$bb,$d0,$d0), ($2a,$c5,$ef,$ef), ($e5,$4f,$aa,$aa), ($16,$ed,$fb,$fb), + ($c5,$86,$43,$43), ($d7,$9a,$4d,$4d), ($55,$66,$33,$33), ($94,$11,$85,$85), + ($cf,$8a,$45,$45), ($10,$e9,$f9,$f9), ($06,$04,$02,$02), ($81,$fe,$7f,$7f), + ($f0,$a0,$50,$50), ($44,$78,$3c,$3c), ($ba,$25,$9f,$9f), ($e3,$4b,$a8,$a8), + ($f3,$a2,$51,$51), ($fe,$5d,$a3,$a3), ($c0,$80,$40,$40), ($8a,$05,$8f,$8f), + ($ad,$3f,$92,$92), ($bc,$21,$9d,$9d), ($48,$70,$38,$38), ($04,$f1,$f5,$f5), + ($df,$63,$bc,$bc), ($c1,$77,$b6,$b6), ($75,$af,$da,$da), ($63,$42,$21,$21), + ($30,$20,$10,$10), ($1a,$e5,$ff,$ff), ($0e,$fd,$f3,$f3), ($6d,$bf,$d2,$d2), + ($4c,$81,$cd,$cd), ($14,$18,$0c,$0c), ($35,$26,$13,$13), ($2f,$c3,$ec,$ec), + ($e1,$be,$5f,$5f), ($a2,$35,$97,$97), ($cc,$88,$44,$44), ($39,$2e,$17,$17), + ($57,$93,$c4,$c4), ($f2,$55,$a7,$a7), ($82,$fc,$7e,$7e), ($47,$7a,$3d,$3d), + ($ac,$c8,$64,$64), ($e7,$ba,$5d,$5d), ($2b,$32,$19,$19), ($95,$e6,$73,$73), + ($a0,$c0,$60,$60), ($98,$19,$81,$81), ($d1,$9e,$4f,$4f), ($7f,$a3,$dc,$dc), + ($66,$44,$22,$22), ($7e,$54,$2a,$2a), ($ab,$3b,$90,$90), ($83,$0b,$88,$88), + ($ca,$8c,$46,$46), ($29,$c7,$ee,$ee), ($d3,$6b,$b8,$b8), ($3c,$28,$14,$14), + ($79,$a7,$de,$de), ($e2,$bc,$5e,$5e), ($1d,$16,$0b,$0b), ($76,$ad,$db,$db), + ($3b,$db,$e0,$e0), ($56,$64,$32,$32), ($4e,$74,$3a,$3a), ($1e,$14,$0a,$0a), + ($db,$92,$49,$49), ($0a,$0c,$06,$06), ($6c,$48,$24,$24), ($e4,$b8,$5c,$5c), + ($5d,$9f,$c2,$c2), ($6e,$bd,$d3,$d3), ($ef,$43,$ac,$ac), ($a6,$c4,$62,$62), + ($a8,$39,$91,$91), ($a4,$31,$95,$95), ($37,$d3,$e4,$e4), ($8b,$f2,$79,$79), + ($32,$d5,$e7,$e7), ($43,$8b,$c8,$c8), ($59,$6e,$37,$37), ($b7,$da,$6d,$6d), + ($8c,$01,$8d,$8d), ($64,$b1,$d5,$d5), ($d2,$9c,$4e,$4e), ($e0,$49,$a9,$a9), + ($b4,$d8,$6c,$6c), ($fa,$ac,$56,$56), ($07,$f3,$f4,$f4), ($25,$cf,$ea,$ea), + ($af,$ca,$65,$65), ($8e,$f4,$7a,$7a), ($e9,$47,$ae,$ae), ($18,$10,$08,$08), + ($d5,$6f,$ba,$ba), ($88,$f0,$78,$78), ($6f,$4a,$25,$25), ($72,$5c,$2e,$2e), + ($24,$38,$1c,$1c), ($f1,$57,$a6,$a6), ($c7,$73,$b4,$b4), ($51,$97,$c6,$c6), + ($23,$cb,$e8,$e8), ($7c,$a1,$dd,$dd), ($9c,$e8,$74,$74), ($21,$3e,$1f,$1f), + ($dd,$96,$4b,$4b), ($dc,$61,$bd,$bd), ($86,$0d,$8b,$8b), ($85,$0f,$8a,$8a), + ($90,$e0,$70,$70), ($42,$7c,$3e,$3e), ($c4,$71,$b5,$b5), ($aa,$cc,$66,$66), + ($d8,$90,$48,$48), ($05,$06,$03,$03), ($01,$f7,$f6,$f6), ($12,$1c,$0e,$0e), + ($a3,$c2,$61,$61), ($5f,$6a,$35,$35), ($f9,$ae,$57,$57), ($d0,$69,$b9,$b9), + ($91,$17,$86,$86), ($58,$99,$c1,$c1), ($27,$3a,$1d,$1d), ($b9,$27,$9e,$9e), + ($38,$d9,$e1,$e1), ($13,$eb,$f8,$f8), ($b3,$2b,$98,$98), ($33,$22,$11,$11), + ($bb,$d2,$69,$69), ($70,$a9,$d9,$d9), ($89,$07,$8e,$8e), ($a7,$33,$94,$94), + ($b6,$2d,$9b,$9b), ($22,$3c,$1e,$1e), ($92,$15,$87,$87), ($20,$c9,$e9,$e9), + ($49,$87,$ce,$ce), ($ff,$aa,$55,$55), ($78,$50,$28,$28), ($7a,$a5,$df,$df), + ($8f,$03,$8c,$8c), ($f8,$59,$a1,$a1), ($80,$09,$89,$89), ($17,$1a,$0d,$0d), + ($da,$65,$bf,$bf), ($31,$d7,$e6,$e6), ($c6,$84,$42,$42), ($b8,$d0,$68,$68), + ($c3,$82,$41,$41), ($b0,$29,$99,$99), ($77,$5a,$2d,$2d), ($11,$1e,$0f,$0f), + ($cb,$7b,$b0,$b0), ($fc,$a8,$54,$54), ($d6,$6d,$bb,$bb), ($3a,$2c,$16,$16)); + T3: array[0..255,0..3] of byte= ( + ($63,$a5,$c6,$63), ($7c,$84,$f8,$7c), ($77,$99,$ee,$77), ($7b,$8d,$f6,$7b), + ($f2,$0d,$ff,$f2), ($6b,$bd,$d6,$6b), ($6f,$b1,$de,$6f), ($c5,$54,$91,$c5), + ($30,$50,$60,$30), ($01,$03,$02,$01), ($67,$a9,$ce,$67), ($2b,$7d,$56,$2b), + ($fe,$19,$e7,$fe), ($d7,$62,$b5,$d7), ($ab,$e6,$4d,$ab), ($76,$9a,$ec,$76), + ($ca,$45,$8f,$ca), ($82,$9d,$1f,$82), ($c9,$40,$89,$c9), ($7d,$87,$fa,$7d), + ($fa,$15,$ef,$fa), ($59,$eb,$b2,$59), ($47,$c9,$8e,$47), ($f0,$0b,$fb,$f0), + ($ad,$ec,$41,$ad), ($d4,$67,$b3,$d4), ($a2,$fd,$5f,$a2), ($af,$ea,$45,$af), + ($9c,$bf,$23,$9c), ($a4,$f7,$53,$a4), ($72,$96,$e4,$72), ($c0,$5b,$9b,$c0), + ($b7,$c2,$75,$b7), ($fd,$1c,$e1,$fd), ($93,$ae,$3d,$93), ($26,$6a,$4c,$26), + ($36,$5a,$6c,$36), ($3f,$41,$7e,$3f), ($f7,$02,$f5,$f7), ($cc,$4f,$83,$cc), + ($34,$5c,$68,$34), ($a5,$f4,$51,$a5), ($e5,$34,$d1,$e5), ($f1,$08,$f9,$f1), + ($71,$93,$e2,$71), ($d8,$73,$ab,$d8), ($31,$53,$62,$31), ($15,$3f,$2a,$15), + ($04,$0c,$08,$04), ($c7,$52,$95,$c7), ($23,$65,$46,$23), ($c3,$5e,$9d,$c3), + ($18,$28,$30,$18), ($96,$a1,$37,$96), ($05,$0f,$0a,$05), ($9a,$b5,$2f,$9a), + ($07,$09,$0e,$07), ($12,$36,$24,$12), ($80,$9b,$1b,$80), ($e2,$3d,$df,$e2), + ($eb,$26,$cd,$eb), ($27,$69,$4e,$27), ($b2,$cd,$7f,$b2), ($75,$9f,$ea,$75), + ($09,$1b,$12,$09), ($83,$9e,$1d,$83), ($2c,$74,$58,$2c), ($1a,$2e,$34,$1a), + ($1b,$2d,$36,$1b), ($6e,$b2,$dc,$6e), ($5a,$ee,$b4,$5a), ($a0,$fb,$5b,$a0), + ($52,$f6,$a4,$52), ($3b,$4d,$76,$3b), ($d6,$61,$b7,$d6), ($b3,$ce,$7d,$b3), + ($29,$7b,$52,$29), ($e3,$3e,$dd,$e3), ($2f,$71,$5e,$2f), ($84,$97,$13,$84), + ($53,$f5,$a6,$53), ($d1,$68,$b9,$d1), ($00,$00,$00,$00), ($ed,$2c,$c1,$ed), + ($20,$60,$40,$20), ($fc,$1f,$e3,$fc), ($b1,$c8,$79,$b1), ($5b,$ed,$b6,$5b), + ($6a,$be,$d4,$6a), ($cb,$46,$8d,$cb), ($be,$d9,$67,$be), ($39,$4b,$72,$39), + ($4a,$de,$94,$4a), ($4c,$d4,$98,$4c), ($58,$e8,$b0,$58), ($cf,$4a,$85,$cf), + ($d0,$6b,$bb,$d0), ($ef,$2a,$c5,$ef), ($aa,$e5,$4f,$aa), ($fb,$16,$ed,$fb), + ($43,$c5,$86,$43), ($4d,$d7,$9a,$4d), ($33,$55,$66,$33), ($85,$94,$11,$85), + ($45,$cf,$8a,$45), ($f9,$10,$e9,$f9), ($02,$06,$04,$02), ($7f,$81,$fe,$7f), + ($50,$f0,$a0,$50), ($3c,$44,$78,$3c), ($9f,$ba,$25,$9f), ($a8,$e3,$4b,$a8), + ($51,$f3,$a2,$51), ($a3,$fe,$5d,$a3), ($40,$c0,$80,$40), ($8f,$8a,$05,$8f), + ($92,$ad,$3f,$92), ($9d,$bc,$21,$9d), ($38,$48,$70,$38), ($f5,$04,$f1,$f5), + ($bc,$df,$63,$bc), ($b6,$c1,$77,$b6), ($da,$75,$af,$da), ($21,$63,$42,$21), + ($10,$30,$20,$10), ($ff,$1a,$e5,$ff), ($f3,$0e,$fd,$f3), ($d2,$6d,$bf,$d2), + ($cd,$4c,$81,$cd), ($0c,$14,$18,$0c), ($13,$35,$26,$13), ($ec,$2f,$c3,$ec), + ($5f,$e1,$be,$5f), ($97,$a2,$35,$97), ($44,$cc,$88,$44), ($17,$39,$2e,$17), + ($c4,$57,$93,$c4), ($a7,$f2,$55,$a7), ($7e,$82,$fc,$7e), ($3d,$47,$7a,$3d), + ($64,$ac,$c8,$64), ($5d,$e7,$ba,$5d), ($19,$2b,$32,$19), ($73,$95,$e6,$73), + ($60,$a0,$c0,$60), ($81,$98,$19,$81), ($4f,$d1,$9e,$4f), ($dc,$7f,$a3,$dc), + ($22,$66,$44,$22), ($2a,$7e,$54,$2a), ($90,$ab,$3b,$90), ($88,$83,$0b,$88), + ($46,$ca,$8c,$46), ($ee,$29,$c7,$ee), ($b8,$d3,$6b,$b8), ($14,$3c,$28,$14), + ($de,$79,$a7,$de), ($5e,$e2,$bc,$5e), ($0b,$1d,$16,$0b), ($db,$76,$ad,$db), + ($e0,$3b,$db,$e0), ($32,$56,$64,$32), ($3a,$4e,$74,$3a), ($0a,$1e,$14,$0a), + ($49,$db,$92,$49), ($06,$0a,$0c,$06), ($24,$6c,$48,$24), ($5c,$e4,$b8,$5c), + ($c2,$5d,$9f,$c2), ($d3,$6e,$bd,$d3), ($ac,$ef,$43,$ac), ($62,$a6,$c4,$62), + ($91,$a8,$39,$91), ($95,$a4,$31,$95), ($e4,$37,$d3,$e4), ($79,$8b,$f2,$79), + ($e7,$32,$d5,$e7), ($c8,$43,$8b,$c8), ($37,$59,$6e,$37), ($6d,$b7,$da,$6d), + ($8d,$8c,$01,$8d), ($d5,$64,$b1,$d5), ($4e,$d2,$9c,$4e), ($a9,$e0,$49,$a9), + ($6c,$b4,$d8,$6c), ($56,$fa,$ac,$56), ($f4,$07,$f3,$f4), ($ea,$25,$cf,$ea), + ($65,$af,$ca,$65), ($7a,$8e,$f4,$7a), ($ae,$e9,$47,$ae), ($08,$18,$10,$08), + ($ba,$d5,$6f,$ba), ($78,$88,$f0,$78), ($25,$6f,$4a,$25), ($2e,$72,$5c,$2e), + ($1c,$24,$38,$1c), ($a6,$f1,$57,$a6), ($b4,$c7,$73,$b4), ($c6,$51,$97,$c6), + ($e8,$23,$cb,$e8), ($dd,$7c,$a1,$dd), ($74,$9c,$e8,$74), ($1f,$21,$3e,$1f), + ($4b,$dd,$96,$4b), ($bd,$dc,$61,$bd), ($8b,$86,$0d,$8b), ($8a,$85,$0f,$8a), + ($70,$90,$e0,$70), ($3e,$42,$7c,$3e), ($b5,$c4,$71,$b5), ($66,$aa,$cc,$66), + ($48,$d8,$90,$48), ($03,$05,$06,$03), ($f6,$01,$f7,$f6), ($0e,$12,$1c,$0e), + ($61,$a3,$c2,$61), ($35,$5f,$6a,$35), ($57,$f9,$ae,$57), ($b9,$d0,$69,$b9), + ($86,$91,$17,$86), ($c1,$58,$99,$c1), ($1d,$27,$3a,$1d), ($9e,$b9,$27,$9e), + ($e1,$38,$d9,$e1), ($f8,$13,$eb,$f8), ($98,$b3,$2b,$98), ($11,$33,$22,$11), + ($69,$bb,$d2,$69), ($d9,$70,$a9,$d9), ($8e,$89,$07,$8e), ($94,$a7,$33,$94), + ($9b,$b6,$2d,$9b), ($1e,$22,$3c,$1e), ($87,$92,$15,$87), ($e9,$20,$c9,$e9), + ($ce,$49,$87,$ce), ($55,$ff,$aa,$55), ($28,$78,$50,$28), ($df,$7a,$a5,$df), + ($8c,$8f,$03,$8c), ($a1,$f8,$59,$a1), ($89,$80,$09,$89), ($0d,$17,$1a,$0d), + ($bf,$da,$65,$bf), ($e6,$31,$d7,$e6), ($42,$c6,$84,$42), ($68,$b8,$d0,$68), + ($41,$c3,$82,$41), ($99,$b0,$29,$99), ($2d,$77,$5a,$2d), ($0f,$11,$1e,$0f), + ($b0,$cb,$7b,$b0), ($54,$fc,$a8,$54), ($bb,$d6,$6d,$bb), ($16,$3a,$2c,$16)); + T4: array[0..255,0..3] of byte= ( + ($63,$63,$a5,$c6), ($7c,$7c,$84,$f8), ($77,$77,$99,$ee), ($7b,$7b,$8d,$f6), + ($f2,$f2,$0d,$ff), ($6b,$6b,$bd,$d6), ($6f,$6f,$b1,$de), ($c5,$c5,$54,$91), + ($30,$30,$50,$60), ($01,$01,$03,$02), ($67,$67,$a9,$ce), ($2b,$2b,$7d,$56), + ($fe,$fe,$19,$e7), ($d7,$d7,$62,$b5), ($ab,$ab,$e6,$4d), ($76,$76,$9a,$ec), + ($ca,$ca,$45,$8f), ($82,$82,$9d,$1f), ($c9,$c9,$40,$89), ($7d,$7d,$87,$fa), + ($fa,$fa,$15,$ef), ($59,$59,$eb,$b2), ($47,$47,$c9,$8e), ($f0,$f0,$0b,$fb), + ($ad,$ad,$ec,$41), ($d4,$d4,$67,$b3), ($a2,$a2,$fd,$5f), ($af,$af,$ea,$45), + ($9c,$9c,$bf,$23), ($a4,$a4,$f7,$53), ($72,$72,$96,$e4), ($c0,$c0,$5b,$9b), + ($b7,$b7,$c2,$75), ($fd,$fd,$1c,$e1), ($93,$93,$ae,$3d), ($26,$26,$6a,$4c), + ($36,$36,$5a,$6c), ($3f,$3f,$41,$7e), ($f7,$f7,$02,$f5), ($cc,$cc,$4f,$83), + ($34,$34,$5c,$68), ($a5,$a5,$f4,$51), ($e5,$e5,$34,$d1), ($f1,$f1,$08,$f9), + ($71,$71,$93,$e2), ($d8,$d8,$73,$ab), ($31,$31,$53,$62), ($15,$15,$3f,$2a), + ($04,$04,$0c,$08), ($c7,$c7,$52,$95), ($23,$23,$65,$46), ($c3,$c3,$5e,$9d), + ($18,$18,$28,$30), ($96,$96,$a1,$37), ($05,$05,$0f,$0a), ($9a,$9a,$b5,$2f), + ($07,$07,$09,$0e), ($12,$12,$36,$24), ($80,$80,$9b,$1b), ($e2,$e2,$3d,$df), + ($eb,$eb,$26,$cd), ($27,$27,$69,$4e), ($b2,$b2,$cd,$7f), ($75,$75,$9f,$ea), + ($09,$09,$1b,$12), ($83,$83,$9e,$1d), ($2c,$2c,$74,$58), ($1a,$1a,$2e,$34), + ($1b,$1b,$2d,$36), ($6e,$6e,$b2,$dc), ($5a,$5a,$ee,$b4), ($a0,$a0,$fb,$5b), + ($52,$52,$f6,$a4), ($3b,$3b,$4d,$76), ($d6,$d6,$61,$b7), ($b3,$b3,$ce,$7d), + ($29,$29,$7b,$52), ($e3,$e3,$3e,$dd), ($2f,$2f,$71,$5e), ($84,$84,$97,$13), + ($53,$53,$f5,$a6), ($d1,$d1,$68,$b9), ($00,$00,$00,$00), ($ed,$ed,$2c,$c1), + ($20,$20,$60,$40), ($fc,$fc,$1f,$e3), ($b1,$b1,$c8,$79), ($5b,$5b,$ed,$b6), + ($6a,$6a,$be,$d4), ($cb,$cb,$46,$8d), ($be,$be,$d9,$67), ($39,$39,$4b,$72), + ($4a,$4a,$de,$94), ($4c,$4c,$d4,$98), ($58,$58,$e8,$b0), ($cf,$cf,$4a,$85), + ($d0,$d0,$6b,$bb), ($ef,$ef,$2a,$c5), ($aa,$aa,$e5,$4f), ($fb,$fb,$16,$ed), + ($43,$43,$c5,$86), ($4d,$4d,$d7,$9a), ($33,$33,$55,$66), ($85,$85,$94,$11), + ($45,$45,$cf,$8a), ($f9,$f9,$10,$e9), ($02,$02,$06,$04), ($7f,$7f,$81,$fe), + ($50,$50,$f0,$a0), ($3c,$3c,$44,$78), ($9f,$9f,$ba,$25), ($a8,$a8,$e3,$4b), + ($51,$51,$f3,$a2), ($a3,$a3,$fe,$5d), ($40,$40,$c0,$80), ($8f,$8f,$8a,$05), + ($92,$92,$ad,$3f), ($9d,$9d,$bc,$21), ($38,$38,$48,$70), ($f5,$f5,$04,$f1), + ($bc,$bc,$df,$63), ($b6,$b6,$c1,$77), ($da,$da,$75,$af), ($21,$21,$63,$42), + ($10,$10,$30,$20), ($ff,$ff,$1a,$e5), ($f3,$f3,$0e,$fd), ($d2,$d2,$6d,$bf), + ($cd,$cd,$4c,$81), ($0c,$0c,$14,$18), ($13,$13,$35,$26), ($ec,$ec,$2f,$c3), + ($5f,$5f,$e1,$be), ($97,$97,$a2,$35), ($44,$44,$cc,$88), ($17,$17,$39,$2e), + ($c4,$c4,$57,$93), ($a7,$a7,$f2,$55), ($7e,$7e,$82,$fc), ($3d,$3d,$47,$7a), + ($64,$64,$ac,$c8), ($5d,$5d,$e7,$ba), ($19,$19,$2b,$32), ($73,$73,$95,$e6), + ($60,$60,$a0,$c0), ($81,$81,$98,$19), ($4f,$4f,$d1,$9e), ($dc,$dc,$7f,$a3), + ($22,$22,$66,$44), ($2a,$2a,$7e,$54), ($90,$90,$ab,$3b), ($88,$88,$83,$0b), + ($46,$46,$ca,$8c), ($ee,$ee,$29,$c7), ($b8,$b8,$d3,$6b), ($14,$14,$3c,$28), + ($de,$de,$79,$a7), ($5e,$5e,$e2,$bc), ($0b,$0b,$1d,$16), ($db,$db,$76,$ad), + ($e0,$e0,$3b,$db), ($32,$32,$56,$64), ($3a,$3a,$4e,$74), ($0a,$0a,$1e,$14), + ($49,$49,$db,$92), ($06,$06,$0a,$0c), ($24,$24,$6c,$48), ($5c,$5c,$e4,$b8), + ($c2,$c2,$5d,$9f), ($d3,$d3,$6e,$bd), ($ac,$ac,$ef,$43), ($62,$62,$a6,$c4), + ($91,$91,$a8,$39), ($95,$95,$a4,$31), ($e4,$e4,$37,$d3), ($79,$79,$8b,$f2), + ($e7,$e7,$32,$d5), ($c8,$c8,$43,$8b), ($37,$37,$59,$6e), ($6d,$6d,$b7,$da), + ($8d,$8d,$8c,$01), ($d5,$d5,$64,$b1), ($4e,$4e,$d2,$9c), ($a9,$a9,$e0,$49), + ($6c,$6c,$b4,$d8), ($56,$56,$fa,$ac), ($f4,$f4,$07,$f3), ($ea,$ea,$25,$cf), + ($65,$65,$af,$ca), ($7a,$7a,$8e,$f4), ($ae,$ae,$e9,$47), ($08,$08,$18,$10), + ($ba,$ba,$d5,$6f), ($78,$78,$88,$f0), ($25,$25,$6f,$4a), ($2e,$2e,$72,$5c), + ($1c,$1c,$24,$38), ($a6,$a6,$f1,$57), ($b4,$b4,$c7,$73), ($c6,$c6,$51,$97), + ($e8,$e8,$23,$cb), ($dd,$dd,$7c,$a1), ($74,$74,$9c,$e8), ($1f,$1f,$21,$3e), + ($4b,$4b,$dd,$96), ($bd,$bd,$dc,$61), ($8b,$8b,$86,$0d), ($8a,$8a,$85,$0f), + ($70,$70,$90,$e0), ($3e,$3e,$42,$7c), ($b5,$b5,$c4,$71), ($66,$66,$aa,$cc), + ($48,$48,$d8,$90), ($03,$03,$05,$06), ($f6,$f6,$01,$f7), ($0e,$0e,$12,$1c), + ($61,$61,$a3,$c2), ($35,$35,$5f,$6a), ($57,$57,$f9,$ae), ($b9,$b9,$d0,$69), + ($86,$86,$91,$17), ($c1,$c1,$58,$99), ($1d,$1d,$27,$3a), ($9e,$9e,$b9,$27), + ($e1,$e1,$38,$d9), ($f8,$f8,$13,$eb), ($98,$98,$b3,$2b), ($11,$11,$33,$22), + ($69,$69,$bb,$d2), ($d9,$d9,$70,$a9), ($8e,$8e,$89,$07), ($94,$94,$a7,$33), + ($9b,$9b,$b6,$2d), ($1e,$1e,$22,$3c), ($87,$87,$92,$15), ($e9,$e9,$20,$c9), + ($ce,$ce,$49,$87), ($55,$55,$ff,$aa), ($28,$28,$78,$50), ($df,$df,$7a,$a5), + ($8c,$8c,$8f,$03), ($a1,$a1,$f8,$59), ($89,$89,$80,$09), ($0d,$0d,$17,$1a), + ($bf,$bf,$da,$65), ($e6,$e6,$31,$d7), ($42,$42,$c6,$84), ($68,$68,$b8,$d0), + ($41,$41,$c3,$82), ($99,$99,$b0,$29), ($2d,$2d,$77,$5a), ($0f,$0f,$11,$1e), + ($b0,$b0,$cb,$7b), ($54,$54,$fc,$a8), ($bb,$bb,$d6,$6d), ($16,$16,$3a,$2c)); + T5: array[0..255,0..3] of byte= ( + ($51,$f4,$a7,$50), ($7e,$41,$65,$53), ($1a,$17,$a4,$c3), ($3a,$27,$5e,$96), + ($3b,$ab,$6b,$cb), ($1f,$9d,$45,$f1), ($ac,$fa,$58,$ab), ($4b,$e3,$03,$93), + ($20,$30,$fa,$55), ($ad,$76,$6d,$f6), ($88,$cc,$76,$91), ($f5,$02,$4c,$25), + ($4f,$e5,$d7,$fc), ($c5,$2a,$cb,$d7), ($26,$35,$44,$80), ($b5,$62,$a3,$8f), + ($de,$b1,$5a,$49), ($25,$ba,$1b,$67), ($45,$ea,$0e,$98), ($5d,$fe,$c0,$e1), + ($c3,$2f,$75,$02), ($81,$4c,$f0,$12), ($8d,$46,$97,$a3), ($6b,$d3,$f9,$c6), + ($03,$8f,$5f,$e7), ($15,$92,$9c,$95), ($bf,$6d,$7a,$eb), ($95,$52,$59,$da), + ($d4,$be,$83,$2d), ($58,$74,$21,$d3), ($49,$e0,$69,$29), ($8e,$c9,$c8,$44), + ($75,$c2,$89,$6a), ($f4,$8e,$79,$78), ($99,$58,$3e,$6b), ($27,$b9,$71,$dd), + ($be,$e1,$4f,$b6), ($f0,$88,$ad,$17), ($c9,$20,$ac,$66), ($7d,$ce,$3a,$b4), + ($63,$df,$4a,$18), ($e5,$1a,$31,$82), ($97,$51,$33,$60), ($62,$53,$7f,$45), + ($b1,$64,$77,$e0), ($bb,$6b,$ae,$84), ($fe,$81,$a0,$1c), ($f9,$08,$2b,$94), + ($70,$48,$68,$58), ($8f,$45,$fd,$19), ($94,$de,$6c,$87), ($52,$7b,$f8,$b7), + ($ab,$73,$d3,$23), ($72,$4b,$02,$e2), ($e3,$1f,$8f,$57), ($66,$55,$ab,$2a), + ($b2,$eb,$28,$07), ($2f,$b5,$c2,$03), ($86,$c5,$7b,$9a), ($d3,$37,$08,$a5), + ($30,$28,$87,$f2), ($23,$bf,$a5,$b2), ($02,$03,$6a,$ba), ($ed,$16,$82,$5c), + ($8a,$cf,$1c,$2b), ($a7,$79,$b4,$92), ($f3,$07,$f2,$f0), ($4e,$69,$e2,$a1), + ($65,$da,$f4,$cd), ($06,$05,$be,$d5), ($d1,$34,$62,$1f), ($c4,$a6,$fe,$8a), + ($34,$2e,$53,$9d), ($a2,$f3,$55,$a0), ($05,$8a,$e1,$32), ($a4,$f6,$eb,$75), + ($0b,$83,$ec,$39), ($40,$60,$ef,$aa), ($5e,$71,$9f,$06), ($bd,$6e,$10,$51), + ($3e,$21,$8a,$f9), ($96,$dd,$06,$3d), ($dd,$3e,$05,$ae), ($4d,$e6,$bd,$46), + ($91,$54,$8d,$b5), ($71,$c4,$5d,$05), ($04,$06,$d4,$6f), ($60,$50,$15,$ff), + ($19,$98,$fb,$24), ($d6,$bd,$e9,$97), ($89,$40,$43,$cc), ($67,$d9,$9e,$77), + ($b0,$e8,$42,$bd), ($07,$89,$8b,$88), ($e7,$19,$5b,$38), ($79,$c8,$ee,$db), + ($a1,$7c,$0a,$47), ($7c,$42,$0f,$e9), ($f8,$84,$1e,$c9), ($00,$00,$00,$00), + ($09,$80,$86,$83), ($32,$2b,$ed,$48), ($1e,$11,$70,$ac), ($6c,$5a,$72,$4e), + ($fd,$0e,$ff,$fb), ($0f,$85,$38,$56), ($3d,$ae,$d5,$1e), ($36,$2d,$39,$27), + ($0a,$0f,$d9,$64), ($68,$5c,$a6,$21), ($9b,$5b,$54,$d1), ($24,$36,$2e,$3a), + ($0c,$0a,$67,$b1), ($93,$57,$e7,$0f), ($b4,$ee,$96,$d2), ($1b,$9b,$91,$9e), + ($80,$c0,$c5,$4f), ($61,$dc,$20,$a2), ($5a,$77,$4b,$69), ($1c,$12,$1a,$16), + ($e2,$93,$ba,$0a), ($c0,$a0,$2a,$e5), ($3c,$22,$e0,$43), ($12,$1b,$17,$1d), + ($0e,$09,$0d,$0b), ($f2,$8b,$c7,$ad), ($2d,$b6,$a8,$b9), ($14,$1e,$a9,$c8), + ($57,$f1,$19,$85), ($af,$75,$07,$4c), ($ee,$99,$dd,$bb), ($a3,$7f,$60,$fd), + ($f7,$01,$26,$9f), ($5c,$72,$f5,$bc), ($44,$66,$3b,$c5), ($5b,$fb,$7e,$34), + ($8b,$43,$29,$76), ($cb,$23,$c6,$dc), ($b6,$ed,$fc,$68), ($b8,$e4,$f1,$63), + ($d7,$31,$dc,$ca), ($42,$63,$85,$10), ($13,$97,$22,$40), ($84,$c6,$11,$20), + ($85,$4a,$24,$7d), ($d2,$bb,$3d,$f8), ($ae,$f9,$32,$11), ($c7,$29,$a1,$6d), + ($1d,$9e,$2f,$4b), ($dc,$b2,$30,$f3), ($0d,$86,$52,$ec), ($77,$c1,$e3,$d0), + ($2b,$b3,$16,$6c), ($a9,$70,$b9,$99), ($11,$94,$48,$fa), ($47,$e9,$64,$22), + ($a8,$fc,$8c,$c4), ($a0,$f0,$3f,$1a), ($56,$7d,$2c,$d8), ($22,$33,$90,$ef), + ($87,$49,$4e,$c7), ($d9,$38,$d1,$c1), ($8c,$ca,$a2,$fe), ($98,$d4,$0b,$36), + ($a6,$f5,$81,$cf), ($a5,$7a,$de,$28), ($da,$b7,$8e,$26), ($3f,$ad,$bf,$a4), + ($2c,$3a,$9d,$e4), ($50,$78,$92,$0d), ($6a,$5f,$cc,$9b), ($54,$7e,$46,$62), + ($f6,$8d,$13,$c2), ($90,$d8,$b8,$e8), ($2e,$39,$f7,$5e), ($82,$c3,$af,$f5), + ($9f,$5d,$80,$be), ($69,$d0,$93,$7c), ($6f,$d5,$2d,$a9), ($cf,$25,$12,$b3), + ($c8,$ac,$99,$3b), ($10,$18,$7d,$a7), ($e8,$9c,$63,$6e), ($db,$3b,$bb,$7b), + ($cd,$26,$78,$09), ($6e,$59,$18,$f4), ($ec,$9a,$b7,$01), ($83,$4f,$9a,$a8), + ($e6,$95,$6e,$65), ($aa,$ff,$e6,$7e), ($21,$bc,$cf,$08), ($ef,$15,$e8,$e6), + ($ba,$e7,$9b,$d9), ($4a,$6f,$36,$ce), ($ea,$9f,$09,$d4), ($29,$b0,$7c,$d6), + ($31,$a4,$b2,$af), ($2a,$3f,$23,$31), ($c6,$a5,$94,$30), ($35,$a2,$66,$c0), + ($74,$4e,$bc,$37), ($fc,$82,$ca,$a6), ($e0,$90,$d0,$b0), ($33,$a7,$d8,$15), + ($f1,$04,$98,$4a), ($41,$ec,$da,$f7), ($7f,$cd,$50,$0e), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($43,$ef,$b0,$4d), ($cc,$aa,$4d,$54), ($e4,$96,$04,$df), + ($9e,$d1,$b5,$e3), ($4c,$6a,$88,$1b), ($c1,$2c,$1f,$b8), ($46,$65,$51,$7f), + ($9d,$5e,$ea,$04), ($01,$8c,$35,$5d), ($fa,$87,$74,$73), ($fb,$0b,$41,$2e), + ($b3,$67,$1d,$5a), ($92,$db,$d2,$52), ($e9,$10,$56,$33), ($6d,$d6,$47,$13), + ($9a,$d7,$61,$8c), ($37,$a1,$0c,$7a), ($59,$f8,$14,$8e), ($eb,$13,$3c,$89), + ($ce,$a9,$27,$ee), ($b7,$61,$c9,$35), ($e1,$1c,$e5,$ed), ($7a,$47,$b1,$3c), + ($9c,$d2,$df,$59), ($55,$f2,$73,$3f), ($18,$14,$ce,$79), ($73,$c7,$37,$bf), + ($53,$f7,$cd,$ea), ($5f,$fd,$aa,$5b), ($df,$3d,$6f,$14), ($78,$44,$db,$86), + ($ca,$af,$f3,$81), ($b9,$68,$c4,$3e), ($38,$24,$34,$2c), ($c2,$a3,$40,$5f), + ($16,$1d,$c3,$72), ($bc,$e2,$25,$0c), ($28,$3c,$49,$8b), ($ff,$0d,$95,$41), + ($39,$a8,$01,$71), ($08,$0c,$b3,$de), ($d8,$b4,$e4,$9c), ($64,$56,$c1,$90), + ($7b,$cb,$84,$61), ($d5,$32,$b6,$70), ($48,$6c,$5c,$74), ($d0,$b8,$57,$42)); + T6: array[0..255,0..3] of byte= ( + ($50,$51,$f4,$a7), ($53,$7e,$41,$65), ($c3,$1a,$17,$a4), ($96,$3a,$27,$5e), + ($cb,$3b,$ab,$6b), ($f1,$1f,$9d,$45), ($ab,$ac,$fa,$58), ($93,$4b,$e3,$03), + ($55,$20,$30,$fa), ($f6,$ad,$76,$6d), ($91,$88,$cc,$76), ($25,$f5,$02,$4c), + ($fc,$4f,$e5,$d7), ($d7,$c5,$2a,$cb), ($80,$26,$35,$44), ($8f,$b5,$62,$a3), + ($49,$de,$b1,$5a), ($67,$25,$ba,$1b), ($98,$45,$ea,$0e), ($e1,$5d,$fe,$c0), + ($02,$c3,$2f,$75), ($12,$81,$4c,$f0), ($a3,$8d,$46,$97), ($c6,$6b,$d3,$f9), + ($e7,$03,$8f,$5f), ($95,$15,$92,$9c), ($eb,$bf,$6d,$7a), ($da,$95,$52,$59), + ($2d,$d4,$be,$83), ($d3,$58,$74,$21), ($29,$49,$e0,$69), ($44,$8e,$c9,$c8), + ($6a,$75,$c2,$89), ($78,$f4,$8e,$79), ($6b,$99,$58,$3e), ($dd,$27,$b9,$71), + ($b6,$be,$e1,$4f), ($17,$f0,$88,$ad), ($66,$c9,$20,$ac), ($b4,$7d,$ce,$3a), + ($18,$63,$df,$4a), ($82,$e5,$1a,$31), ($60,$97,$51,$33), ($45,$62,$53,$7f), + ($e0,$b1,$64,$77), ($84,$bb,$6b,$ae), ($1c,$fe,$81,$a0), ($94,$f9,$08,$2b), + ($58,$70,$48,$68), ($19,$8f,$45,$fd), ($87,$94,$de,$6c), ($b7,$52,$7b,$f8), + ($23,$ab,$73,$d3), ($e2,$72,$4b,$02), ($57,$e3,$1f,$8f), ($2a,$66,$55,$ab), + ($07,$b2,$eb,$28), ($03,$2f,$b5,$c2), ($9a,$86,$c5,$7b), ($a5,$d3,$37,$08), + ($f2,$30,$28,$87), ($b2,$23,$bf,$a5), ($ba,$02,$03,$6a), ($5c,$ed,$16,$82), + ($2b,$8a,$cf,$1c), ($92,$a7,$79,$b4), ($f0,$f3,$07,$f2), ($a1,$4e,$69,$e2), + ($cd,$65,$da,$f4), ($d5,$06,$05,$be), ($1f,$d1,$34,$62), ($8a,$c4,$a6,$fe), + ($9d,$34,$2e,$53), ($a0,$a2,$f3,$55), ($32,$05,$8a,$e1), ($75,$a4,$f6,$eb), + ($39,$0b,$83,$ec), ($aa,$40,$60,$ef), ($06,$5e,$71,$9f), ($51,$bd,$6e,$10), + ($f9,$3e,$21,$8a), ($3d,$96,$dd,$06), ($ae,$dd,$3e,$05), ($46,$4d,$e6,$bd), + ($b5,$91,$54,$8d), ($05,$71,$c4,$5d), ($6f,$04,$06,$d4), ($ff,$60,$50,$15), + ($24,$19,$98,$fb), ($97,$d6,$bd,$e9), ($cc,$89,$40,$43), ($77,$67,$d9,$9e), + ($bd,$b0,$e8,$42), ($88,$07,$89,$8b), ($38,$e7,$19,$5b), ($db,$79,$c8,$ee), + ($47,$a1,$7c,$0a), ($e9,$7c,$42,$0f), ($c9,$f8,$84,$1e), ($00,$00,$00,$00), + ($83,$09,$80,$86), ($48,$32,$2b,$ed), ($ac,$1e,$11,$70), ($4e,$6c,$5a,$72), + ($fb,$fd,$0e,$ff), ($56,$0f,$85,$38), ($1e,$3d,$ae,$d5), ($27,$36,$2d,$39), + ($64,$0a,$0f,$d9), ($21,$68,$5c,$a6), ($d1,$9b,$5b,$54), ($3a,$24,$36,$2e), + ($b1,$0c,$0a,$67), ($0f,$93,$57,$e7), ($d2,$b4,$ee,$96), ($9e,$1b,$9b,$91), + ($4f,$80,$c0,$c5), ($a2,$61,$dc,$20), ($69,$5a,$77,$4b), ($16,$1c,$12,$1a), + ($0a,$e2,$93,$ba), ($e5,$c0,$a0,$2a), ($43,$3c,$22,$e0), ($1d,$12,$1b,$17), + ($0b,$0e,$09,$0d), ($ad,$f2,$8b,$c7), ($b9,$2d,$b6,$a8), ($c8,$14,$1e,$a9), + ($85,$57,$f1,$19), ($4c,$af,$75,$07), ($bb,$ee,$99,$dd), ($fd,$a3,$7f,$60), + ($9f,$f7,$01,$26), ($bc,$5c,$72,$f5), ($c5,$44,$66,$3b), ($34,$5b,$fb,$7e), + ($76,$8b,$43,$29), ($dc,$cb,$23,$c6), ($68,$b6,$ed,$fc), ($63,$b8,$e4,$f1), + ($ca,$d7,$31,$dc), ($10,$42,$63,$85), ($40,$13,$97,$22), ($20,$84,$c6,$11), + ($7d,$85,$4a,$24), ($f8,$d2,$bb,$3d), ($11,$ae,$f9,$32), ($6d,$c7,$29,$a1), + ($4b,$1d,$9e,$2f), ($f3,$dc,$b2,$30), ($ec,$0d,$86,$52), ($d0,$77,$c1,$e3), + ($6c,$2b,$b3,$16), ($99,$a9,$70,$b9), ($fa,$11,$94,$48), ($22,$47,$e9,$64), + ($c4,$a8,$fc,$8c), ($1a,$a0,$f0,$3f), ($d8,$56,$7d,$2c), ($ef,$22,$33,$90), + ($c7,$87,$49,$4e), ($c1,$d9,$38,$d1), ($fe,$8c,$ca,$a2), ($36,$98,$d4,$0b), + ($cf,$a6,$f5,$81), ($28,$a5,$7a,$de), ($26,$da,$b7,$8e), ($a4,$3f,$ad,$bf), + ($e4,$2c,$3a,$9d), ($0d,$50,$78,$92), ($9b,$6a,$5f,$cc), ($62,$54,$7e,$46), + ($c2,$f6,$8d,$13), ($e8,$90,$d8,$b8), ($5e,$2e,$39,$f7), ($f5,$82,$c3,$af), + ($be,$9f,$5d,$80), ($7c,$69,$d0,$93), ($a9,$6f,$d5,$2d), ($b3,$cf,$25,$12), + ($3b,$c8,$ac,$99), ($a7,$10,$18,$7d), ($6e,$e8,$9c,$63), ($7b,$db,$3b,$bb), + ($09,$cd,$26,$78), ($f4,$6e,$59,$18), ($01,$ec,$9a,$b7), ($a8,$83,$4f,$9a), + ($65,$e6,$95,$6e), ($7e,$aa,$ff,$e6), ($08,$21,$bc,$cf), ($e6,$ef,$15,$e8), + ($d9,$ba,$e7,$9b), ($ce,$4a,$6f,$36), ($d4,$ea,$9f,$09), ($d6,$29,$b0,$7c), + ($af,$31,$a4,$b2), ($31,$2a,$3f,$23), ($30,$c6,$a5,$94), ($c0,$35,$a2,$66), + ($37,$74,$4e,$bc), ($a6,$fc,$82,$ca), ($b0,$e0,$90,$d0), ($15,$33,$a7,$d8), + ($4a,$f1,$04,$98), ($f7,$41,$ec,$da), ($0e,$7f,$cd,$50), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($4d,$43,$ef,$b0), ($54,$cc,$aa,$4d), ($df,$e4,$96,$04), + ($e3,$9e,$d1,$b5), ($1b,$4c,$6a,$88), ($b8,$c1,$2c,$1f), ($7f,$46,$65,$51), + ($04,$9d,$5e,$ea), ($5d,$01,$8c,$35), ($73,$fa,$87,$74), ($2e,$fb,$0b,$41), + ($5a,$b3,$67,$1d), ($52,$92,$db,$d2), ($33,$e9,$10,$56), ($13,$6d,$d6,$47), + ($8c,$9a,$d7,$61), ($7a,$37,$a1,$0c), ($8e,$59,$f8,$14), ($89,$eb,$13,$3c), + ($ee,$ce,$a9,$27), ($35,$b7,$61,$c9), ($ed,$e1,$1c,$e5), ($3c,$7a,$47,$b1), + ($59,$9c,$d2,$df), ($3f,$55,$f2,$73), ($79,$18,$14,$ce), ($bf,$73,$c7,$37), + ($ea,$53,$f7,$cd), ($5b,$5f,$fd,$aa), ($14,$df,$3d,$6f), ($86,$78,$44,$db), + ($81,$ca,$af,$f3), ($3e,$b9,$68,$c4), ($2c,$38,$24,$34), ($5f,$c2,$a3,$40), + ($72,$16,$1d,$c3), ($0c,$bc,$e2,$25), ($8b,$28,$3c,$49), ($41,$ff,$0d,$95), + ($71,$39,$a8,$01), ($de,$08,$0c,$b3), ($9c,$d8,$b4,$e4), ($90,$64,$56,$c1), + ($61,$7b,$cb,$84), ($70,$d5,$32,$b6), ($74,$48,$6c,$5c), ($42,$d0,$b8,$57)); + T7: array[0..255,0..3] of byte= ( + ($a7,$50,$51,$f4), ($65,$53,$7e,$41), ($a4,$c3,$1a,$17), ($5e,$96,$3a,$27), + ($6b,$cb,$3b,$ab), ($45,$f1,$1f,$9d), ($58,$ab,$ac,$fa), ($03,$93,$4b,$e3), + ($fa,$55,$20,$30), ($6d,$f6,$ad,$76), ($76,$91,$88,$cc), ($4c,$25,$f5,$02), + ($d7,$fc,$4f,$e5), ($cb,$d7,$c5,$2a), ($44,$80,$26,$35), ($a3,$8f,$b5,$62), + ($5a,$49,$de,$b1), ($1b,$67,$25,$ba), ($0e,$98,$45,$ea), ($c0,$e1,$5d,$fe), + ($75,$02,$c3,$2f), ($f0,$12,$81,$4c), ($97,$a3,$8d,$46), ($f9,$c6,$6b,$d3), + ($5f,$e7,$03,$8f), ($9c,$95,$15,$92), ($7a,$eb,$bf,$6d), ($59,$da,$95,$52), + ($83,$2d,$d4,$be), ($21,$d3,$58,$74), ($69,$29,$49,$e0), ($c8,$44,$8e,$c9), + ($89,$6a,$75,$c2), ($79,$78,$f4,$8e), ($3e,$6b,$99,$58), ($71,$dd,$27,$b9), + ($4f,$b6,$be,$e1), ($ad,$17,$f0,$88), ($ac,$66,$c9,$20), ($3a,$b4,$7d,$ce), + ($4a,$18,$63,$df), ($31,$82,$e5,$1a), ($33,$60,$97,$51), ($7f,$45,$62,$53), + ($77,$e0,$b1,$64), ($ae,$84,$bb,$6b), ($a0,$1c,$fe,$81), ($2b,$94,$f9,$08), + ($68,$58,$70,$48), ($fd,$19,$8f,$45), ($6c,$87,$94,$de), ($f8,$b7,$52,$7b), + ($d3,$23,$ab,$73), ($02,$e2,$72,$4b), ($8f,$57,$e3,$1f), ($ab,$2a,$66,$55), + ($28,$07,$b2,$eb), ($c2,$03,$2f,$b5), ($7b,$9a,$86,$c5), ($08,$a5,$d3,$37), + ($87,$f2,$30,$28), ($a5,$b2,$23,$bf), ($6a,$ba,$02,$03), ($82,$5c,$ed,$16), + ($1c,$2b,$8a,$cf), ($b4,$92,$a7,$79), ($f2,$f0,$f3,$07), ($e2,$a1,$4e,$69), + ($f4,$cd,$65,$da), ($be,$d5,$06,$05), ($62,$1f,$d1,$34), ($fe,$8a,$c4,$a6), + ($53,$9d,$34,$2e), ($55,$a0,$a2,$f3), ($e1,$32,$05,$8a), ($eb,$75,$a4,$f6), + ($ec,$39,$0b,$83), ($ef,$aa,$40,$60), ($9f,$06,$5e,$71), ($10,$51,$bd,$6e), + ($8a,$f9,$3e,$21), ($06,$3d,$96,$dd), ($05,$ae,$dd,$3e), ($bd,$46,$4d,$e6), + ($8d,$b5,$91,$54), ($5d,$05,$71,$c4), ($d4,$6f,$04,$06), ($15,$ff,$60,$50), + ($fb,$24,$19,$98), ($e9,$97,$d6,$bd), ($43,$cc,$89,$40), ($9e,$77,$67,$d9), + ($42,$bd,$b0,$e8), ($8b,$88,$07,$89), ($5b,$38,$e7,$19), ($ee,$db,$79,$c8), + ($0a,$47,$a1,$7c), ($0f,$e9,$7c,$42), ($1e,$c9,$f8,$84), ($00,$00,$00,$00), + ($86,$83,$09,$80), ($ed,$48,$32,$2b), ($70,$ac,$1e,$11), ($72,$4e,$6c,$5a), + ($ff,$fb,$fd,$0e), ($38,$56,$0f,$85), ($d5,$1e,$3d,$ae), ($39,$27,$36,$2d), + ($d9,$64,$0a,$0f), ($a6,$21,$68,$5c), ($54,$d1,$9b,$5b), ($2e,$3a,$24,$36), + ($67,$b1,$0c,$0a), ($e7,$0f,$93,$57), ($96,$d2,$b4,$ee), ($91,$9e,$1b,$9b), + ($c5,$4f,$80,$c0), ($20,$a2,$61,$dc), ($4b,$69,$5a,$77), ($1a,$16,$1c,$12), + ($ba,$0a,$e2,$93), ($2a,$e5,$c0,$a0), ($e0,$43,$3c,$22), ($17,$1d,$12,$1b), + ($0d,$0b,$0e,$09), ($c7,$ad,$f2,$8b), ($a8,$b9,$2d,$b6), ($a9,$c8,$14,$1e), + ($19,$85,$57,$f1), ($07,$4c,$af,$75), ($dd,$bb,$ee,$99), ($60,$fd,$a3,$7f), + ($26,$9f,$f7,$01), ($f5,$bc,$5c,$72), ($3b,$c5,$44,$66), ($7e,$34,$5b,$fb), + ($29,$76,$8b,$43), ($c6,$dc,$cb,$23), ($fc,$68,$b6,$ed), ($f1,$63,$b8,$e4), + ($dc,$ca,$d7,$31), ($85,$10,$42,$63), ($22,$40,$13,$97), ($11,$20,$84,$c6), + ($24,$7d,$85,$4a), ($3d,$f8,$d2,$bb), ($32,$11,$ae,$f9), ($a1,$6d,$c7,$29), + ($2f,$4b,$1d,$9e), ($30,$f3,$dc,$b2), ($52,$ec,$0d,$86), ($e3,$d0,$77,$c1), + ($16,$6c,$2b,$b3), ($b9,$99,$a9,$70), ($48,$fa,$11,$94), ($64,$22,$47,$e9), + ($8c,$c4,$a8,$fc), ($3f,$1a,$a0,$f0), ($2c,$d8,$56,$7d), ($90,$ef,$22,$33), + ($4e,$c7,$87,$49), ($d1,$c1,$d9,$38), ($a2,$fe,$8c,$ca), ($0b,$36,$98,$d4), + ($81,$cf,$a6,$f5), ($de,$28,$a5,$7a), ($8e,$26,$da,$b7), ($bf,$a4,$3f,$ad), + ($9d,$e4,$2c,$3a), ($92,$0d,$50,$78), ($cc,$9b,$6a,$5f), ($46,$62,$54,$7e), + ($13,$c2,$f6,$8d), ($b8,$e8,$90,$d8), ($f7,$5e,$2e,$39), ($af,$f5,$82,$c3), + ($80,$be,$9f,$5d), ($93,$7c,$69,$d0), ($2d,$a9,$6f,$d5), ($12,$b3,$cf,$25), + ($99,$3b,$c8,$ac), ($7d,$a7,$10,$18), ($63,$6e,$e8,$9c), ($bb,$7b,$db,$3b), + ($78,$09,$cd,$26), ($18,$f4,$6e,$59), ($b7,$01,$ec,$9a), ($9a,$a8,$83,$4f), + ($6e,$65,$e6,$95), ($e6,$7e,$aa,$ff), ($cf,$08,$21,$bc), ($e8,$e6,$ef,$15), + ($9b,$d9,$ba,$e7), ($36,$ce,$4a,$6f), ($09,$d4,$ea,$9f), ($7c,$d6,$29,$b0), + ($b2,$af,$31,$a4), ($23,$31,$2a,$3f), ($94,$30,$c6,$a5), ($66,$c0,$35,$a2), + ($bc,$37,$74,$4e), ($ca,$a6,$fc,$82), ($d0,$b0,$e0,$90), ($d8,$15,$33,$a7), + ($98,$4a,$f1,$04), ($da,$f7,$41,$ec), ($50,$0e,$7f,$cd), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($b0,$4d,$43,$ef), ($4d,$54,$cc,$aa), ($04,$df,$e4,$96), + ($b5,$e3,$9e,$d1), ($88,$1b,$4c,$6a), ($1f,$b8,$c1,$2c), ($51,$7f,$46,$65), + ($ea,$04,$9d,$5e), ($35,$5d,$01,$8c), ($74,$73,$fa,$87), ($41,$2e,$fb,$0b), + ($1d,$5a,$b3,$67), ($d2,$52,$92,$db), ($56,$33,$e9,$10), ($47,$13,$6d,$d6), + ($61,$8c,$9a,$d7), ($0c,$7a,$37,$a1), ($14,$8e,$59,$f8), ($3c,$89,$eb,$13), + ($27,$ee,$ce,$a9), ($c9,$35,$b7,$61), ($e5,$ed,$e1,$1c), ($b1,$3c,$7a,$47), + ($df,$59,$9c,$d2), ($73,$3f,$55,$f2), ($ce,$79,$18,$14), ($37,$bf,$73,$c7), + ($cd,$ea,$53,$f7), ($aa,$5b,$5f,$fd), ($6f,$14,$df,$3d), ($db,$86,$78,$44), + ($f3,$81,$ca,$af), ($c4,$3e,$b9,$68), ($34,$2c,$38,$24), ($40,$5f,$c2,$a3), + ($c3,$72,$16,$1d), ($25,$0c,$bc,$e2), ($49,$8b,$28,$3c), ($95,$41,$ff,$0d), + ($01,$71,$39,$a8), ($b3,$de,$08,$0c), ($e4,$9c,$d8,$b4), ($c1,$90,$64,$56), + ($84,$61,$7b,$cb), ($b6,$70,$d5,$32), ($5c,$74,$48,$6c), ($57,$42,$d0,$b8)); + T8: array[0..255,0..3] of byte= ( + ($f4,$a7,$50,$51), ($41,$65,$53,$7e), ($17,$a4,$c3,$1a), ($27,$5e,$96,$3a), + ($ab,$6b,$cb,$3b), ($9d,$45,$f1,$1f), ($fa,$58,$ab,$ac), ($e3,$03,$93,$4b), + ($30,$fa,$55,$20), ($76,$6d,$f6,$ad), ($cc,$76,$91,$88), ($02,$4c,$25,$f5), + ($e5,$d7,$fc,$4f), ($2a,$cb,$d7,$c5), ($35,$44,$80,$26), ($62,$a3,$8f,$b5), + ($b1,$5a,$49,$de), ($ba,$1b,$67,$25), ($ea,$0e,$98,$45), ($fe,$c0,$e1,$5d), + ($2f,$75,$02,$c3), ($4c,$f0,$12,$81), ($46,$97,$a3,$8d), ($d3,$f9,$c6,$6b), + ($8f,$5f,$e7,$03), ($92,$9c,$95,$15), ($6d,$7a,$eb,$bf), ($52,$59,$da,$95), + ($be,$83,$2d,$d4), ($74,$21,$d3,$58), ($e0,$69,$29,$49), ($c9,$c8,$44,$8e), + ($c2,$89,$6a,$75), ($8e,$79,$78,$f4), ($58,$3e,$6b,$99), ($b9,$71,$dd,$27), + ($e1,$4f,$b6,$be), ($88,$ad,$17,$f0), ($20,$ac,$66,$c9), ($ce,$3a,$b4,$7d), + ($df,$4a,$18,$63), ($1a,$31,$82,$e5), ($51,$33,$60,$97), ($53,$7f,$45,$62), + ($64,$77,$e0,$b1), ($6b,$ae,$84,$bb), ($81,$a0,$1c,$fe), ($08,$2b,$94,$f9), + ($48,$68,$58,$70), ($45,$fd,$19,$8f), ($de,$6c,$87,$94), ($7b,$f8,$b7,$52), + ($73,$d3,$23,$ab), ($4b,$02,$e2,$72), ($1f,$8f,$57,$e3), ($55,$ab,$2a,$66), + ($eb,$28,$07,$b2), ($b5,$c2,$03,$2f), ($c5,$7b,$9a,$86), ($37,$08,$a5,$d3), + ($28,$87,$f2,$30), ($bf,$a5,$b2,$23), ($03,$6a,$ba,$02), ($16,$82,$5c,$ed), + ($cf,$1c,$2b,$8a), ($79,$b4,$92,$a7), ($07,$f2,$f0,$f3), ($69,$e2,$a1,$4e), + ($da,$f4,$cd,$65), ($05,$be,$d5,$06), ($34,$62,$1f,$d1), ($a6,$fe,$8a,$c4), + ($2e,$53,$9d,$34), ($f3,$55,$a0,$a2), ($8a,$e1,$32,$05), ($f6,$eb,$75,$a4), + ($83,$ec,$39,$0b), ($60,$ef,$aa,$40), ($71,$9f,$06,$5e), ($6e,$10,$51,$bd), + ($21,$8a,$f9,$3e), ($dd,$06,$3d,$96), ($3e,$05,$ae,$dd), ($e6,$bd,$46,$4d), + ($54,$8d,$b5,$91), ($c4,$5d,$05,$71), ($06,$d4,$6f,$04), ($50,$15,$ff,$60), + ($98,$fb,$24,$19), ($bd,$e9,$97,$d6), ($40,$43,$cc,$89), ($d9,$9e,$77,$67), + ($e8,$42,$bd,$b0), ($89,$8b,$88,$07), ($19,$5b,$38,$e7), ($c8,$ee,$db,$79), + ($7c,$0a,$47,$a1), ($42,$0f,$e9,$7c), ($84,$1e,$c9,$f8), ($00,$00,$00,$00), + ($80,$86,$83,$09), ($2b,$ed,$48,$32), ($11,$70,$ac,$1e), ($5a,$72,$4e,$6c), + ($0e,$ff,$fb,$fd), ($85,$38,$56,$0f), ($ae,$d5,$1e,$3d), ($2d,$39,$27,$36), + ($0f,$d9,$64,$0a), ($5c,$a6,$21,$68), ($5b,$54,$d1,$9b), ($36,$2e,$3a,$24), + ($0a,$67,$b1,$0c), ($57,$e7,$0f,$93), ($ee,$96,$d2,$b4), ($9b,$91,$9e,$1b), + ($c0,$c5,$4f,$80), ($dc,$20,$a2,$61), ($77,$4b,$69,$5a), ($12,$1a,$16,$1c), + ($93,$ba,$0a,$e2), ($a0,$2a,$e5,$c0), ($22,$e0,$43,$3c), ($1b,$17,$1d,$12), + ($09,$0d,$0b,$0e), ($8b,$c7,$ad,$f2), ($b6,$a8,$b9,$2d), ($1e,$a9,$c8,$14), + ($f1,$19,$85,$57), ($75,$07,$4c,$af), ($99,$dd,$bb,$ee), ($7f,$60,$fd,$a3), + ($01,$26,$9f,$f7), ($72,$f5,$bc,$5c), ($66,$3b,$c5,$44), ($fb,$7e,$34,$5b), + ($43,$29,$76,$8b), ($23,$c6,$dc,$cb), ($ed,$fc,$68,$b6), ($e4,$f1,$63,$b8), + ($31,$dc,$ca,$d7), ($63,$85,$10,$42), ($97,$22,$40,$13), ($c6,$11,$20,$84), + ($4a,$24,$7d,$85), ($bb,$3d,$f8,$d2), ($f9,$32,$11,$ae), ($29,$a1,$6d,$c7), + ($9e,$2f,$4b,$1d), ($b2,$30,$f3,$dc), ($86,$52,$ec,$0d), ($c1,$e3,$d0,$77), + ($b3,$16,$6c,$2b), ($70,$b9,$99,$a9), ($94,$48,$fa,$11), ($e9,$64,$22,$47), + ($fc,$8c,$c4,$a8), ($f0,$3f,$1a,$a0), ($7d,$2c,$d8,$56), ($33,$90,$ef,$22), + ($49,$4e,$c7,$87), ($38,$d1,$c1,$d9), ($ca,$a2,$fe,$8c), ($d4,$0b,$36,$98), + ($f5,$81,$cf,$a6), ($7a,$de,$28,$a5), ($b7,$8e,$26,$da), ($ad,$bf,$a4,$3f), + ($3a,$9d,$e4,$2c), ($78,$92,$0d,$50), ($5f,$cc,$9b,$6a), ($7e,$46,$62,$54), + ($8d,$13,$c2,$f6), ($d8,$b8,$e8,$90), ($39,$f7,$5e,$2e), ($c3,$af,$f5,$82), + ($5d,$80,$be,$9f), ($d0,$93,$7c,$69), ($d5,$2d,$a9,$6f), ($25,$12,$b3,$cf), + ($ac,$99,$3b,$c8), ($18,$7d,$a7,$10), ($9c,$63,$6e,$e8), ($3b,$bb,$7b,$db), + ($26,$78,$09,$cd), ($59,$18,$f4,$6e), ($9a,$b7,$01,$ec), ($4f,$9a,$a8,$83), + ($95,$6e,$65,$e6), ($ff,$e6,$7e,$aa), ($bc,$cf,$08,$21), ($15,$e8,$e6,$ef), + ($e7,$9b,$d9,$ba), ($6f,$36,$ce,$4a), ($9f,$09,$d4,$ea), ($b0,$7c,$d6,$29), + ($a4,$b2,$af,$31), ($3f,$23,$31,$2a), ($a5,$94,$30,$c6), ($a2,$66,$c0,$35), + ($4e,$bc,$37,$74), ($82,$ca,$a6,$fc), ($90,$d0,$b0,$e0), ($a7,$d8,$15,$33), + ($04,$98,$4a,$f1), ($ec,$da,$f7,$41), ($cd,$50,$0e,$7f), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($ef,$b0,$4d,$43), ($aa,$4d,$54,$cc), ($96,$04,$df,$e4), + ($d1,$b5,$e3,$9e), ($6a,$88,$1b,$4c), ($2c,$1f,$b8,$c1), ($65,$51,$7f,$46), + ($5e,$ea,$04,$9d), ($8c,$35,$5d,$01), ($87,$74,$73,$fa), ($0b,$41,$2e,$fb), + ($67,$1d,$5a,$b3), ($db,$d2,$52,$92), ($10,$56,$33,$e9), ($d6,$47,$13,$6d), + ($d7,$61,$8c,$9a), ($a1,$0c,$7a,$37), ($f8,$14,$8e,$59), ($13,$3c,$89,$eb), + ($a9,$27,$ee,$ce), ($61,$c9,$35,$b7), ($1c,$e5,$ed,$e1), ($47,$b1,$3c,$7a), + ($d2,$df,$59,$9c), ($f2,$73,$3f,$55), ($14,$ce,$79,$18), ($c7,$37,$bf,$73), + ($f7,$cd,$ea,$53), ($fd,$aa,$5b,$5f), ($3d,$6f,$14,$df), ($44,$db,$86,$78), + ($af,$f3,$81,$ca), ($68,$c4,$3e,$b9), ($24,$34,$2c,$38), ($a3,$40,$5f,$c2), + ($1d,$c3,$72,$16), ($e2,$25,$0c,$bc), ($3c,$49,$8b,$28), ($0d,$95,$41,$ff), + ($a8,$01,$71,$39), ($0c,$b3,$de,$08), ($b4,$e4,$9c,$d8), ($56,$c1,$90,$64), + ($cb,$84,$61,$7b), ($32,$b6,$70,$d5), ($6c,$5c,$74,$48), ($b8,$57,$42,$d0)); + S5: array[0..255] of byte= ( + $52,$09,$6a,$d5, + $30,$36,$a5,$38, + $bf,$40,$a3,$9e, + $81,$f3,$d7,$fb, + $7c,$e3,$39,$82, + $9b,$2f,$ff,$87, + $34,$8e,$43,$44, + $c4,$de,$e9,$cb, + $54,$7b,$94,$32, + $a6,$c2,$23,$3d, + $ee,$4c,$95,$0b, + $42,$fa,$c3,$4e, + $08,$2e,$a1,$66, + $28,$d9,$24,$b2, + $76,$5b,$a2,$49, + $6d,$8b,$d1,$25, + $72,$f8,$f6,$64, + $86,$68,$98,$16, + $d4,$a4,$5c,$cc, + $5d,$65,$b6,$92, + $6c,$70,$48,$50, + $fd,$ed,$b9,$da, + $5e,$15,$46,$57, + $a7,$8d,$9d,$84, + $90,$d8,$ab,$00, + $8c,$bc,$d3,$0a, + $f7,$e4,$58,$05, + $b8,$b3,$45,$06, + $d0,$2c,$1e,$8f, + $ca,$3f,$0f,$02, + $c1,$af,$bd,$03, + $01,$13,$8a,$6b, + $3a,$91,$11,$41, + $4f,$67,$dc,$ea, + $97,$f2,$cf,$ce, + $f0,$b4,$e6,$73, + $96,$ac,$74,$22, + $e7,$ad,$35,$85, + $e2,$f9,$37,$e8, + $1c,$75,$df,$6e, + $47,$f1,$1a,$71, + $1d,$29,$c5,$89, + $6f,$b7,$62,$0e, + $aa,$18,$be,$1b, + $fc,$56,$3e,$4b, + $c6,$d2,$79,$20, + $9a,$db,$c0,$fe, + $78,$cd,$5a,$f4, + $1f,$dd,$a8,$33, + $88,$07,$c7,$31, + $b1,$12,$10,$59, + $27,$80,$ec,$5f, + $60,$51,$7f,$a9, + $19,$b5,$4a,$0d, + $2d,$e5,$7a,$9f, + $93,$c9,$9c,$ef, + $a0,$e0,$3b,$4d, + $ae,$2a,$f5,$b0, + $c8,$eb,$bb,$3c, + $83,$53,$99,$61, + $17,$2b,$04,$7e, + $ba,$77,$d6,$26, + $e1,$69,$14,$63, + $55,$21,$0c,$7d); + U1: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0e,$09,$0d,$0b), ($1c,$12,$1a,$16), ($12,$1b,$17,$1d), + ($38,$24,$34,$2c), ($36,$2d,$39,$27), ($24,$36,$2e,$3a), ($2a,$3f,$23,$31), + ($70,$48,$68,$58), ($7e,$41,$65,$53), ($6c,$5a,$72,$4e), ($62,$53,$7f,$45), + ($48,$6c,$5c,$74), ($46,$65,$51,$7f), ($54,$7e,$46,$62), ($5a,$77,$4b,$69), + ($e0,$90,$d0,$b0), ($ee,$99,$dd,$bb), ($fc,$82,$ca,$a6), ($f2,$8b,$c7,$ad), + ($d8,$b4,$e4,$9c), ($d6,$bd,$e9,$97), ($c4,$a6,$fe,$8a), ($ca,$af,$f3,$81), + ($90,$d8,$b8,$e8), ($9e,$d1,$b5,$e3), ($8c,$ca,$a2,$fe), ($82,$c3,$af,$f5), + ($a8,$fc,$8c,$c4), ($a6,$f5,$81,$cf), ($b4,$ee,$96,$d2), ($ba,$e7,$9b,$d9), + ($db,$3b,$bb,$7b), ($d5,$32,$b6,$70), ($c7,$29,$a1,$6d), ($c9,$20,$ac,$66), + ($e3,$1f,$8f,$57), ($ed,$16,$82,$5c), ($ff,$0d,$95,$41), ($f1,$04,$98,$4a), + ($ab,$73,$d3,$23), ($a5,$7a,$de,$28), ($b7,$61,$c9,$35), ($b9,$68,$c4,$3e), + ($93,$57,$e7,$0f), ($9d,$5e,$ea,$04), ($8f,$45,$fd,$19), ($81,$4c,$f0,$12), + ($3b,$ab,$6b,$cb), ($35,$a2,$66,$c0), ($27,$b9,$71,$dd), ($29,$b0,$7c,$d6), + ($03,$8f,$5f,$e7), ($0d,$86,$52,$ec), ($1f,$9d,$45,$f1), ($11,$94,$48,$fa), + ($4b,$e3,$03,$93), ($45,$ea,$0e,$98), ($57,$f1,$19,$85), ($59,$f8,$14,$8e), + ($73,$c7,$37,$bf), ($7d,$ce,$3a,$b4), ($6f,$d5,$2d,$a9), ($61,$dc,$20,$a2), + ($ad,$76,$6d,$f6), ($a3,$7f,$60,$fd), ($b1,$64,$77,$e0), ($bf,$6d,$7a,$eb), + ($95,$52,$59,$da), ($9b,$5b,$54,$d1), ($89,$40,$43,$cc), ($87,$49,$4e,$c7), + ($dd,$3e,$05,$ae), ($d3,$37,$08,$a5), ($c1,$2c,$1f,$b8), ($cf,$25,$12,$b3), + ($e5,$1a,$31,$82), ($eb,$13,$3c,$89), ($f9,$08,$2b,$94), ($f7,$01,$26,$9f), + ($4d,$e6,$bd,$46), ($43,$ef,$b0,$4d), ($51,$f4,$a7,$50), ($5f,$fd,$aa,$5b), + ($75,$c2,$89,$6a), ($7b,$cb,$84,$61), ($69,$d0,$93,$7c), ($67,$d9,$9e,$77), + ($3d,$ae,$d5,$1e), ($33,$a7,$d8,$15), ($21,$bc,$cf,$08), ($2f,$b5,$c2,$03), + ($05,$8a,$e1,$32), ($0b,$83,$ec,$39), ($19,$98,$fb,$24), ($17,$91,$f6,$2f), + ($76,$4d,$d6,$8d), ($78,$44,$db,$86), ($6a,$5f,$cc,$9b), ($64,$56,$c1,$90), + ($4e,$69,$e2,$a1), ($40,$60,$ef,$aa), ($52,$7b,$f8,$b7), ($5c,$72,$f5,$bc), + ($06,$05,$be,$d5), ($08,$0c,$b3,$de), ($1a,$17,$a4,$c3), ($14,$1e,$a9,$c8), + ($3e,$21,$8a,$f9), ($30,$28,$87,$f2), ($22,$33,$90,$ef), ($2c,$3a,$9d,$e4), + ($96,$dd,$06,$3d), ($98,$d4,$0b,$36), ($8a,$cf,$1c,$2b), ($84,$c6,$11,$20), + ($ae,$f9,$32,$11), ($a0,$f0,$3f,$1a), ($b2,$eb,$28,$07), ($bc,$e2,$25,$0c), + ($e6,$95,$6e,$65), ($e8,$9c,$63,$6e), ($fa,$87,$74,$73), ($f4,$8e,$79,$78), + ($de,$b1,$5a,$49), ($d0,$b8,$57,$42), ($c2,$a3,$40,$5f), ($cc,$aa,$4d,$54), + ($41,$ec,$da,$f7), ($4f,$e5,$d7,$fc), ($5d,$fe,$c0,$e1), ($53,$f7,$cd,$ea), + ($79,$c8,$ee,$db), ($77,$c1,$e3,$d0), ($65,$da,$f4,$cd), ($6b,$d3,$f9,$c6), + ($31,$a4,$b2,$af), ($3f,$ad,$bf,$a4), ($2d,$b6,$a8,$b9), ($23,$bf,$a5,$b2), + ($09,$80,$86,$83), ($07,$89,$8b,$88), ($15,$92,$9c,$95), ($1b,$9b,$91,$9e), + ($a1,$7c,$0a,$47), ($af,$75,$07,$4c), ($bd,$6e,$10,$51), ($b3,$67,$1d,$5a), + ($99,$58,$3e,$6b), ($97,$51,$33,$60), ($85,$4a,$24,$7d), ($8b,$43,$29,$76), + ($d1,$34,$62,$1f), ($df,$3d,$6f,$14), ($cd,$26,$78,$09), ($c3,$2f,$75,$02), + ($e9,$10,$56,$33), ($e7,$19,$5b,$38), ($f5,$02,$4c,$25), ($fb,$0b,$41,$2e), + ($9a,$d7,$61,$8c), ($94,$de,$6c,$87), ($86,$c5,$7b,$9a), ($88,$cc,$76,$91), + ($a2,$f3,$55,$a0), ($ac,$fa,$58,$ab), ($be,$e1,$4f,$b6), ($b0,$e8,$42,$bd), + ($ea,$9f,$09,$d4), ($e4,$96,$04,$df), ($f6,$8d,$13,$c2), ($f8,$84,$1e,$c9), + ($d2,$bb,$3d,$f8), ($dc,$b2,$30,$f3), ($ce,$a9,$27,$ee), ($c0,$a0,$2a,$e5), + ($7a,$47,$b1,$3c), ($74,$4e,$bc,$37), ($66,$55,$ab,$2a), ($68,$5c,$a6,$21), + ($42,$63,$85,$10), ($4c,$6a,$88,$1b), ($5e,$71,$9f,$06), ($50,$78,$92,$0d), + ($0a,$0f,$d9,$64), ($04,$06,$d4,$6f), ($16,$1d,$c3,$72), ($18,$14,$ce,$79), + ($32,$2b,$ed,$48), ($3c,$22,$e0,$43), ($2e,$39,$f7,$5e), ($20,$30,$fa,$55), + ($ec,$9a,$b7,$01), ($e2,$93,$ba,$0a), ($f0,$88,$ad,$17), ($fe,$81,$a0,$1c), + ($d4,$be,$83,$2d), ($da,$b7,$8e,$26), ($c8,$ac,$99,$3b), ($c6,$a5,$94,$30), + ($9c,$d2,$df,$59), ($92,$db,$d2,$52), ($80,$c0,$c5,$4f), ($8e,$c9,$c8,$44), + ($a4,$f6,$eb,$75), ($aa,$ff,$e6,$7e), ($b8,$e4,$f1,$63), ($b6,$ed,$fc,$68), + ($0c,$0a,$67,$b1), ($02,$03,$6a,$ba), ($10,$18,$7d,$a7), ($1e,$11,$70,$ac), + ($34,$2e,$53,$9d), ($3a,$27,$5e,$96), ($28,$3c,$49,$8b), ($26,$35,$44,$80), + ($7c,$42,$0f,$e9), ($72,$4b,$02,$e2), ($60,$50,$15,$ff), ($6e,$59,$18,$f4), + ($44,$66,$3b,$c5), ($4a,$6f,$36,$ce), ($58,$74,$21,$d3), ($56,$7d,$2c,$d8), + ($37,$a1,$0c,$7a), ($39,$a8,$01,$71), ($2b,$b3,$16,$6c), ($25,$ba,$1b,$67), + ($0f,$85,$38,$56), ($01,$8c,$35,$5d), ($13,$97,$22,$40), ($1d,$9e,$2f,$4b), + ($47,$e9,$64,$22), ($49,$e0,$69,$29), ($5b,$fb,$7e,$34), ($55,$f2,$73,$3f), + ($7f,$cd,$50,$0e), ($71,$c4,$5d,$05), ($63,$df,$4a,$18), ($6d,$d6,$47,$13), + ($d7,$31,$dc,$ca), ($d9,$38,$d1,$c1), ($cb,$23,$c6,$dc), ($c5,$2a,$cb,$d7), + ($ef,$15,$e8,$e6), ($e1,$1c,$e5,$ed), ($f3,$07,$f2,$f0), ($fd,$0e,$ff,$fb), + ($a7,$79,$b4,$92), ($a9,$70,$b9,$99), ($bb,$6b,$ae,$84), ($b5,$62,$a3,$8f), + ($9f,$5d,$80,$be), ($91,$54,$8d,$b5), ($83,$4f,$9a,$a8), ($8d,$46,$97,$a3)); + U2: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0b,$0e,$09,$0d), ($16,$1c,$12,$1a), ($1d,$12,$1b,$17), + ($2c,$38,$24,$34), ($27,$36,$2d,$39), ($3a,$24,$36,$2e), ($31,$2a,$3f,$23), + ($58,$70,$48,$68), ($53,$7e,$41,$65), ($4e,$6c,$5a,$72), ($45,$62,$53,$7f), + ($74,$48,$6c,$5c), ($7f,$46,$65,$51), ($62,$54,$7e,$46), ($69,$5a,$77,$4b), + ($b0,$e0,$90,$d0), ($bb,$ee,$99,$dd), ($a6,$fc,$82,$ca), ($ad,$f2,$8b,$c7), + ($9c,$d8,$b4,$e4), ($97,$d6,$bd,$e9), ($8a,$c4,$a6,$fe), ($81,$ca,$af,$f3), + ($e8,$90,$d8,$b8), ($e3,$9e,$d1,$b5), ($fe,$8c,$ca,$a2), ($f5,$82,$c3,$af), + ($c4,$a8,$fc,$8c), ($cf,$a6,$f5,$81), ($d2,$b4,$ee,$96), ($d9,$ba,$e7,$9b), + ($7b,$db,$3b,$bb), ($70,$d5,$32,$b6), ($6d,$c7,$29,$a1), ($66,$c9,$20,$ac), + ($57,$e3,$1f,$8f), ($5c,$ed,$16,$82), ($41,$ff,$0d,$95), ($4a,$f1,$04,$98), + ($23,$ab,$73,$d3), ($28,$a5,$7a,$de), ($35,$b7,$61,$c9), ($3e,$b9,$68,$c4), + ($0f,$93,$57,$e7), ($04,$9d,$5e,$ea), ($19,$8f,$45,$fd), ($12,$81,$4c,$f0), + ($cb,$3b,$ab,$6b), ($c0,$35,$a2,$66), ($dd,$27,$b9,$71), ($d6,$29,$b0,$7c), + ($e7,$03,$8f,$5f), ($ec,$0d,$86,$52), ($f1,$1f,$9d,$45), ($fa,$11,$94,$48), + ($93,$4b,$e3,$03), ($98,$45,$ea,$0e), ($85,$57,$f1,$19), ($8e,$59,$f8,$14), + ($bf,$73,$c7,$37), ($b4,$7d,$ce,$3a), ($a9,$6f,$d5,$2d), ($a2,$61,$dc,$20), + ($f6,$ad,$76,$6d), ($fd,$a3,$7f,$60), ($e0,$b1,$64,$77), ($eb,$bf,$6d,$7a), + ($da,$95,$52,$59), ($d1,$9b,$5b,$54), ($cc,$89,$40,$43), ($c7,$87,$49,$4e), + ($ae,$dd,$3e,$05), ($a5,$d3,$37,$08), ($b8,$c1,$2c,$1f), ($b3,$cf,$25,$12), + ($82,$e5,$1a,$31), ($89,$eb,$13,$3c), ($94,$f9,$08,$2b), ($9f,$f7,$01,$26), + ($46,$4d,$e6,$bd), ($4d,$43,$ef,$b0), ($50,$51,$f4,$a7), ($5b,$5f,$fd,$aa), + ($6a,$75,$c2,$89), ($61,$7b,$cb,$84), ($7c,$69,$d0,$93), ($77,$67,$d9,$9e), + ($1e,$3d,$ae,$d5), ($15,$33,$a7,$d8), ($08,$21,$bc,$cf), ($03,$2f,$b5,$c2), + ($32,$05,$8a,$e1), ($39,$0b,$83,$ec), ($24,$19,$98,$fb), ($2f,$17,$91,$f6), + ($8d,$76,$4d,$d6), ($86,$78,$44,$db), ($9b,$6a,$5f,$cc), ($90,$64,$56,$c1), + ($a1,$4e,$69,$e2), ($aa,$40,$60,$ef), ($b7,$52,$7b,$f8), ($bc,$5c,$72,$f5), + ($d5,$06,$05,$be), ($de,$08,$0c,$b3), ($c3,$1a,$17,$a4), ($c8,$14,$1e,$a9), + ($f9,$3e,$21,$8a), ($f2,$30,$28,$87), ($ef,$22,$33,$90), ($e4,$2c,$3a,$9d), + ($3d,$96,$dd,$06), ($36,$98,$d4,$0b), ($2b,$8a,$cf,$1c), ($20,$84,$c6,$11), + ($11,$ae,$f9,$32), ($1a,$a0,$f0,$3f), ($07,$b2,$eb,$28), ($0c,$bc,$e2,$25), + ($65,$e6,$95,$6e), ($6e,$e8,$9c,$63), ($73,$fa,$87,$74), ($78,$f4,$8e,$79), + ($49,$de,$b1,$5a), ($42,$d0,$b8,$57), ($5f,$c2,$a3,$40), ($54,$cc,$aa,$4d), + ($f7,$41,$ec,$da), ($fc,$4f,$e5,$d7), ($e1,$5d,$fe,$c0), ($ea,$53,$f7,$cd), + ($db,$79,$c8,$ee), ($d0,$77,$c1,$e3), ($cd,$65,$da,$f4), ($c6,$6b,$d3,$f9), + ($af,$31,$a4,$b2), ($a4,$3f,$ad,$bf), ($b9,$2d,$b6,$a8), ($b2,$23,$bf,$a5), + ($83,$09,$80,$86), ($88,$07,$89,$8b), ($95,$15,$92,$9c), ($9e,$1b,$9b,$91), + ($47,$a1,$7c,$0a), ($4c,$af,$75,$07), ($51,$bd,$6e,$10), ($5a,$b3,$67,$1d), + ($6b,$99,$58,$3e), ($60,$97,$51,$33), ($7d,$85,$4a,$24), ($76,$8b,$43,$29), + ($1f,$d1,$34,$62), ($14,$df,$3d,$6f), ($09,$cd,$26,$78), ($02,$c3,$2f,$75), + ($33,$e9,$10,$56), ($38,$e7,$19,$5b), ($25,$f5,$02,$4c), ($2e,$fb,$0b,$41), + ($8c,$9a,$d7,$61), ($87,$94,$de,$6c), ($9a,$86,$c5,$7b), ($91,$88,$cc,$76), + ($a0,$a2,$f3,$55), ($ab,$ac,$fa,$58), ($b6,$be,$e1,$4f), ($bd,$b0,$e8,$42), + ($d4,$ea,$9f,$09), ($df,$e4,$96,$04), ($c2,$f6,$8d,$13), ($c9,$f8,$84,$1e), + ($f8,$d2,$bb,$3d), ($f3,$dc,$b2,$30), ($ee,$ce,$a9,$27), ($e5,$c0,$a0,$2a), + ($3c,$7a,$47,$b1), ($37,$74,$4e,$bc), ($2a,$66,$55,$ab), ($21,$68,$5c,$a6), + ($10,$42,$63,$85), ($1b,$4c,$6a,$88), ($06,$5e,$71,$9f), ($0d,$50,$78,$92), + ($64,$0a,$0f,$d9), ($6f,$04,$06,$d4), ($72,$16,$1d,$c3), ($79,$18,$14,$ce), + ($48,$32,$2b,$ed), ($43,$3c,$22,$e0), ($5e,$2e,$39,$f7), ($55,$20,$30,$fa), + ($01,$ec,$9a,$b7), ($0a,$e2,$93,$ba), ($17,$f0,$88,$ad), ($1c,$fe,$81,$a0), + ($2d,$d4,$be,$83), ($26,$da,$b7,$8e), ($3b,$c8,$ac,$99), ($30,$c6,$a5,$94), + ($59,$9c,$d2,$df), ($52,$92,$db,$d2), ($4f,$80,$c0,$c5), ($44,$8e,$c9,$c8), + ($75,$a4,$f6,$eb), ($7e,$aa,$ff,$e6), ($63,$b8,$e4,$f1), ($68,$b6,$ed,$fc), + ($b1,$0c,$0a,$67), ($ba,$02,$03,$6a), ($a7,$10,$18,$7d), ($ac,$1e,$11,$70), + ($9d,$34,$2e,$53), ($96,$3a,$27,$5e), ($8b,$28,$3c,$49), ($80,$26,$35,$44), + ($e9,$7c,$42,$0f), ($e2,$72,$4b,$02), ($ff,$60,$50,$15), ($f4,$6e,$59,$18), + ($c5,$44,$66,$3b), ($ce,$4a,$6f,$36), ($d3,$58,$74,$21), ($d8,$56,$7d,$2c), + ($7a,$37,$a1,$0c), ($71,$39,$a8,$01), ($6c,$2b,$b3,$16), ($67,$25,$ba,$1b), + ($56,$0f,$85,$38), ($5d,$01,$8c,$35), ($40,$13,$97,$22), ($4b,$1d,$9e,$2f), + ($22,$47,$e9,$64), ($29,$49,$e0,$69), ($34,$5b,$fb,$7e), ($3f,$55,$f2,$73), + ($0e,$7f,$cd,$50), ($05,$71,$c4,$5d), ($18,$63,$df,$4a), ($13,$6d,$d6,$47), + ($ca,$d7,$31,$dc), ($c1,$d9,$38,$d1), ($dc,$cb,$23,$c6), ($d7,$c5,$2a,$cb), + ($e6,$ef,$15,$e8), ($ed,$e1,$1c,$e5), ($f0,$f3,$07,$f2), ($fb,$fd,$0e,$ff), + ($92,$a7,$79,$b4), ($99,$a9,$70,$b9), ($84,$bb,$6b,$ae), ($8f,$b5,$62,$a3), + ($be,$9f,$5d,$80), ($b5,$91,$54,$8d), ($a8,$83,$4f,$9a), ($a3,$8d,$46,$97)); + U3: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($0d,$0b,$0e,$09), ($1a,$16,$1c,$12), ($17,$1d,$12,$1b), + ($34,$2c,$38,$24), ($39,$27,$36,$2d), ($2e,$3a,$24,$36), ($23,$31,$2a,$3f), + ($68,$58,$70,$48), ($65,$53,$7e,$41), ($72,$4e,$6c,$5a), ($7f,$45,$62,$53), + ($5c,$74,$48,$6c), ($51,$7f,$46,$65), ($46,$62,$54,$7e), ($4b,$69,$5a,$77), + ($d0,$b0,$e0,$90), ($dd,$bb,$ee,$99), ($ca,$a6,$fc,$82), ($c7,$ad,$f2,$8b), + ($e4,$9c,$d8,$b4), ($e9,$97,$d6,$bd), ($fe,$8a,$c4,$a6), ($f3,$81,$ca,$af), + ($b8,$e8,$90,$d8), ($b5,$e3,$9e,$d1), ($a2,$fe,$8c,$ca), ($af,$f5,$82,$c3), + ($8c,$c4,$a8,$fc), ($81,$cf,$a6,$f5), ($96,$d2,$b4,$ee), ($9b,$d9,$ba,$e7), + ($bb,$7b,$db,$3b), ($b6,$70,$d5,$32), ($a1,$6d,$c7,$29), ($ac,$66,$c9,$20), + ($8f,$57,$e3,$1f), ($82,$5c,$ed,$16), ($95,$41,$ff,$0d), ($98,$4a,$f1,$04), + ($d3,$23,$ab,$73), ($de,$28,$a5,$7a), ($c9,$35,$b7,$61), ($c4,$3e,$b9,$68), + ($e7,$0f,$93,$57), ($ea,$04,$9d,$5e), ($fd,$19,$8f,$45), ($f0,$12,$81,$4c), + ($6b,$cb,$3b,$ab), ($66,$c0,$35,$a2), ($71,$dd,$27,$b9), ($7c,$d6,$29,$b0), + ($5f,$e7,$03,$8f), ($52,$ec,$0d,$86), ($45,$f1,$1f,$9d), ($48,$fa,$11,$94), + ($03,$93,$4b,$e3), ($0e,$98,$45,$ea), ($19,$85,$57,$f1), ($14,$8e,$59,$f8), + ($37,$bf,$73,$c7), ($3a,$b4,$7d,$ce), ($2d,$a9,$6f,$d5), ($20,$a2,$61,$dc), + ($6d,$f6,$ad,$76), ($60,$fd,$a3,$7f), ($77,$e0,$b1,$64), ($7a,$eb,$bf,$6d), + ($59,$da,$95,$52), ($54,$d1,$9b,$5b), ($43,$cc,$89,$40), ($4e,$c7,$87,$49), + ($05,$ae,$dd,$3e), ($08,$a5,$d3,$37), ($1f,$b8,$c1,$2c), ($12,$b3,$cf,$25), + ($31,$82,$e5,$1a), ($3c,$89,$eb,$13), ($2b,$94,$f9,$08), ($26,$9f,$f7,$01), + ($bd,$46,$4d,$e6), ($b0,$4d,$43,$ef), ($a7,$50,$51,$f4), ($aa,$5b,$5f,$fd), + ($89,$6a,$75,$c2), ($84,$61,$7b,$cb), ($93,$7c,$69,$d0), ($9e,$77,$67,$d9), + ($d5,$1e,$3d,$ae), ($d8,$15,$33,$a7), ($cf,$08,$21,$bc), ($c2,$03,$2f,$b5), + ($e1,$32,$05,$8a), ($ec,$39,$0b,$83), ($fb,$24,$19,$98), ($f6,$2f,$17,$91), + ($d6,$8d,$76,$4d), ($db,$86,$78,$44), ($cc,$9b,$6a,$5f), ($c1,$90,$64,$56), + ($e2,$a1,$4e,$69), ($ef,$aa,$40,$60), ($f8,$b7,$52,$7b), ($f5,$bc,$5c,$72), + ($be,$d5,$06,$05), ($b3,$de,$08,$0c), ($a4,$c3,$1a,$17), ($a9,$c8,$14,$1e), + ($8a,$f9,$3e,$21), ($87,$f2,$30,$28), ($90,$ef,$22,$33), ($9d,$e4,$2c,$3a), + ($06,$3d,$96,$dd), ($0b,$36,$98,$d4), ($1c,$2b,$8a,$cf), ($11,$20,$84,$c6), + ($32,$11,$ae,$f9), ($3f,$1a,$a0,$f0), ($28,$07,$b2,$eb), ($25,$0c,$bc,$e2), + ($6e,$65,$e6,$95), ($63,$6e,$e8,$9c), ($74,$73,$fa,$87), ($79,$78,$f4,$8e), + ($5a,$49,$de,$b1), ($57,$42,$d0,$b8), ($40,$5f,$c2,$a3), ($4d,$54,$cc,$aa), + ($da,$f7,$41,$ec), ($d7,$fc,$4f,$e5), ($c0,$e1,$5d,$fe), ($cd,$ea,$53,$f7), + ($ee,$db,$79,$c8), ($e3,$d0,$77,$c1), ($f4,$cd,$65,$da), ($f9,$c6,$6b,$d3), + ($b2,$af,$31,$a4), ($bf,$a4,$3f,$ad), ($a8,$b9,$2d,$b6), ($a5,$b2,$23,$bf), + ($86,$83,$09,$80), ($8b,$88,$07,$89), ($9c,$95,$15,$92), ($91,$9e,$1b,$9b), + ($0a,$47,$a1,$7c), ($07,$4c,$af,$75), ($10,$51,$bd,$6e), ($1d,$5a,$b3,$67), + ($3e,$6b,$99,$58), ($33,$60,$97,$51), ($24,$7d,$85,$4a), ($29,$76,$8b,$43), + ($62,$1f,$d1,$34), ($6f,$14,$df,$3d), ($78,$09,$cd,$26), ($75,$02,$c3,$2f), + ($56,$33,$e9,$10), ($5b,$38,$e7,$19), ($4c,$25,$f5,$02), ($41,$2e,$fb,$0b), + ($61,$8c,$9a,$d7), ($6c,$87,$94,$de), ($7b,$9a,$86,$c5), ($76,$91,$88,$cc), + ($55,$a0,$a2,$f3), ($58,$ab,$ac,$fa), ($4f,$b6,$be,$e1), ($42,$bd,$b0,$e8), + ($09,$d4,$ea,$9f), ($04,$df,$e4,$96), ($13,$c2,$f6,$8d), ($1e,$c9,$f8,$84), + ($3d,$f8,$d2,$bb), ($30,$f3,$dc,$b2), ($27,$ee,$ce,$a9), ($2a,$e5,$c0,$a0), + ($b1,$3c,$7a,$47), ($bc,$37,$74,$4e), ($ab,$2a,$66,$55), ($a6,$21,$68,$5c), + ($85,$10,$42,$63), ($88,$1b,$4c,$6a), ($9f,$06,$5e,$71), ($92,$0d,$50,$78), + ($d9,$64,$0a,$0f), ($d4,$6f,$04,$06), ($c3,$72,$16,$1d), ($ce,$79,$18,$14), + ($ed,$48,$32,$2b), ($e0,$43,$3c,$22), ($f7,$5e,$2e,$39), ($fa,$55,$20,$30), + ($b7,$01,$ec,$9a), ($ba,$0a,$e2,$93), ($ad,$17,$f0,$88), ($a0,$1c,$fe,$81), + ($83,$2d,$d4,$be), ($8e,$26,$da,$b7), ($99,$3b,$c8,$ac), ($94,$30,$c6,$a5), + ($df,$59,$9c,$d2), ($d2,$52,$92,$db), ($c5,$4f,$80,$c0), ($c8,$44,$8e,$c9), + ($eb,$75,$a4,$f6), ($e6,$7e,$aa,$ff), ($f1,$63,$b8,$e4), ($fc,$68,$b6,$ed), + ($67,$b1,$0c,$0a), ($6a,$ba,$02,$03), ($7d,$a7,$10,$18), ($70,$ac,$1e,$11), + ($53,$9d,$34,$2e), ($5e,$96,$3a,$27), ($49,$8b,$28,$3c), ($44,$80,$26,$35), + ($0f,$e9,$7c,$42), ($02,$e2,$72,$4b), ($15,$ff,$60,$50), ($18,$f4,$6e,$59), + ($3b,$c5,$44,$66), ($36,$ce,$4a,$6f), ($21,$d3,$58,$74), ($2c,$d8,$56,$7d), + ($0c,$7a,$37,$a1), ($01,$71,$39,$a8), ($16,$6c,$2b,$b3), ($1b,$67,$25,$ba), + ($38,$56,$0f,$85), ($35,$5d,$01,$8c), ($22,$40,$13,$97), ($2f,$4b,$1d,$9e), + ($64,$22,$47,$e9), ($69,$29,$49,$e0), ($7e,$34,$5b,$fb), ($73,$3f,$55,$f2), + ($50,$0e,$7f,$cd), ($5d,$05,$71,$c4), ($4a,$18,$63,$df), ($47,$13,$6d,$d6), + ($dc,$ca,$d7,$31), ($d1,$c1,$d9,$38), ($c6,$dc,$cb,$23), ($cb,$d7,$c5,$2a), + ($e8,$e6,$ef,$15), ($e5,$ed,$e1,$1c), ($f2,$f0,$f3,$07), ($ff,$fb,$fd,$0e), + ($b4,$92,$a7,$79), ($b9,$99,$a9,$70), ($ae,$84,$bb,$6b), ($a3,$8f,$b5,$62), + ($80,$be,$9f,$5d), ($8d,$b5,$91,$54), ($9a,$a8,$83,$4f), ($97,$a3,$8d,$46)); + U4: array[0..255,0..3] of byte= ( + ($00,$00,$00,$00), ($09,$0d,$0b,$0e), ($12,$1a,$16,$1c), ($1b,$17,$1d,$12), + ($24,$34,$2c,$38), ($2d,$39,$27,$36), ($36,$2e,$3a,$24), ($3f,$23,$31,$2a), + ($48,$68,$58,$70), ($41,$65,$53,$7e), ($5a,$72,$4e,$6c), ($53,$7f,$45,$62), + ($6c,$5c,$74,$48), ($65,$51,$7f,$46), ($7e,$46,$62,$54), ($77,$4b,$69,$5a), + ($90,$d0,$b0,$e0), ($99,$dd,$bb,$ee), ($82,$ca,$a6,$fc), ($8b,$c7,$ad,$f2), + ($b4,$e4,$9c,$d8), ($bd,$e9,$97,$d6), ($a6,$fe,$8a,$c4), ($af,$f3,$81,$ca), + ($d8,$b8,$e8,$90), ($d1,$b5,$e3,$9e), ($ca,$a2,$fe,$8c), ($c3,$af,$f5,$82), + ($fc,$8c,$c4,$a8), ($f5,$81,$cf,$a6), ($ee,$96,$d2,$b4), ($e7,$9b,$d9,$ba), + ($3b,$bb,$7b,$db), ($32,$b6,$70,$d5), ($29,$a1,$6d,$c7), ($20,$ac,$66,$c9), + ($1f,$8f,$57,$e3), ($16,$82,$5c,$ed), ($0d,$95,$41,$ff), ($04,$98,$4a,$f1), + ($73,$d3,$23,$ab), ($7a,$de,$28,$a5), ($61,$c9,$35,$b7), ($68,$c4,$3e,$b9), + ($57,$e7,$0f,$93), ($5e,$ea,$04,$9d), ($45,$fd,$19,$8f), ($4c,$f0,$12,$81), + ($ab,$6b,$cb,$3b), ($a2,$66,$c0,$35), ($b9,$71,$dd,$27), ($b0,$7c,$d6,$29), + ($8f,$5f,$e7,$03), ($86,$52,$ec,$0d), ($9d,$45,$f1,$1f), ($94,$48,$fa,$11), + ($e3,$03,$93,$4b), ($ea,$0e,$98,$45), ($f1,$19,$85,$57), ($f8,$14,$8e,$59), + ($c7,$37,$bf,$73), ($ce,$3a,$b4,$7d), ($d5,$2d,$a9,$6f), ($dc,$20,$a2,$61), + ($76,$6d,$f6,$ad), ($7f,$60,$fd,$a3), ($64,$77,$e0,$b1), ($6d,$7a,$eb,$bf), + ($52,$59,$da,$95), ($5b,$54,$d1,$9b), ($40,$43,$cc,$89), ($49,$4e,$c7,$87), + ($3e,$05,$ae,$dd), ($37,$08,$a5,$d3), ($2c,$1f,$b8,$c1), ($25,$12,$b3,$cf), + ($1a,$31,$82,$e5), ($13,$3c,$89,$eb), ($08,$2b,$94,$f9), ($01,$26,$9f,$f7), + ($e6,$bd,$46,$4d), ($ef,$b0,$4d,$43), ($f4,$a7,$50,$51), ($fd,$aa,$5b,$5f), + ($c2,$89,$6a,$75), ($cb,$84,$61,$7b), ($d0,$93,$7c,$69), ($d9,$9e,$77,$67), + ($ae,$d5,$1e,$3d), ($a7,$d8,$15,$33), ($bc,$cf,$08,$21), ($b5,$c2,$03,$2f), + ($8a,$e1,$32,$05), ($83,$ec,$39,$0b), ($98,$fb,$24,$19), ($91,$f6,$2f,$17), + ($4d,$d6,$8d,$76), ($44,$db,$86,$78), ($5f,$cc,$9b,$6a), ($56,$c1,$90,$64), + ($69,$e2,$a1,$4e), ($60,$ef,$aa,$40), ($7b,$f8,$b7,$52), ($72,$f5,$bc,$5c), + ($05,$be,$d5,$06), ($0c,$b3,$de,$08), ($17,$a4,$c3,$1a), ($1e,$a9,$c8,$14), + ($21,$8a,$f9,$3e), ($28,$87,$f2,$30), ($33,$90,$ef,$22), ($3a,$9d,$e4,$2c), + ($dd,$06,$3d,$96), ($d4,$0b,$36,$98), ($cf,$1c,$2b,$8a), ($c6,$11,$20,$84), + ($f9,$32,$11,$ae), ($f0,$3f,$1a,$a0), ($eb,$28,$07,$b2), ($e2,$25,$0c,$bc), + ($95,$6e,$65,$e6), ($9c,$63,$6e,$e8), ($87,$74,$73,$fa), ($8e,$79,$78,$f4), + ($b1,$5a,$49,$de), ($b8,$57,$42,$d0), ($a3,$40,$5f,$c2), ($aa,$4d,$54,$cc), + ($ec,$da,$f7,$41), ($e5,$d7,$fc,$4f), ($fe,$c0,$e1,$5d), ($f7,$cd,$ea,$53), + ($c8,$ee,$db,$79), ($c1,$e3,$d0,$77), ($da,$f4,$cd,$65), ($d3,$f9,$c6,$6b), + ($a4,$b2,$af,$31), ($ad,$bf,$a4,$3f), ($b6,$a8,$b9,$2d), ($bf,$a5,$b2,$23), + ($80,$86,$83,$09), ($89,$8b,$88,$07), ($92,$9c,$95,$15), ($9b,$91,$9e,$1b), + ($7c,$0a,$47,$a1), ($75,$07,$4c,$af), ($6e,$10,$51,$bd), ($67,$1d,$5a,$b3), + ($58,$3e,$6b,$99), ($51,$33,$60,$97), ($4a,$24,$7d,$85), ($43,$29,$76,$8b), + ($34,$62,$1f,$d1), ($3d,$6f,$14,$df), ($26,$78,$09,$cd), ($2f,$75,$02,$c3), + ($10,$56,$33,$e9), ($19,$5b,$38,$e7), ($02,$4c,$25,$f5), ($0b,$41,$2e,$fb), + ($d7,$61,$8c,$9a), ($de,$6c,$87,$94), ($c5,$7b,$9a,$86), ($cc,$76,$91,$88), + ($f3,$55,$a0,$a2), ($fa,$58,$ab,$ac), ($e1,$4f,$b6,$be), ($e8,$42,$bd,$b0), + ($9f,$09,$d4,$ea), ($96,$04,$df,$e4), ($8d,$13,$c2,$f6), ($84,$1e,$c9,$f8), + ($bb,$3d,$f8,$d2), ($b2,$30,$f3,$dc), ($a9,$27,$ee,$ce), ($a0,$2a,$e5,$c0), + ($47,$b1,$3c,$7a), ($4e,$bc,$37,$74), ($55,$ab,$2a,$66), ($5c,$a6,$21,$68), + ($63,$85,$10,$42), ($6a,$88,$1b,$4c), ($71,$9f,$06,$5e), ($78,$92,$0d,$50), + ($0f,$d9,$64,$0a), ($06,$d4,$6f,$04), ($1d,$c3,$72,$16), ($14,$ce,$79,$18), + ($2b,$ed,$48,$32), ($22,$e0,$43,$3c), ($39,$f7,$5e,$2e), ($30,$fa,$55,$20), + ($9a,$b7,$01,$ec), ($93,$ba,$0a,$e2), ($88,$ad,$17,$f0), ($81,$a0,$1c,$fe), + ($be,$83,$2d,$d4), ($b7,$8e,$26,$da), ($ac,$99,$3b,$c8), ($a5,$94,$30,$c6), + ($d2,$df,$59,$9c), ($db,$d2,$52,$92), ($c0,$c5,$4f,$80), ($c9,$c8,$44,$8e), + ($f6,$eb,$75,$a4), ($ff,$e6,$7e,$aa), ($e4,$f1,$63,$b8), ($ed,$fc,$68,$b6), + ($0a,$67,$b1,$0c), ($03,$6a,$ba,$02), ($18,$7d,$a7,$10), ($11,$70,$ac,$1e), + ($2e,$53,$9d,$34), ($27,$5e,$96,$3a), ($3c,$49,$8b,$28), ($35,$44,$80,$26), + ($42,$0f,$e9,$7c), ($4b,$02,$e2,$72), ($50,$15,$ff,$60), ($59,$18,$f4,$6e), + ($66,$3b,$c5,$44), ($6f,$36,$ce,$4a), ($74,$21,$d3,$58), ($7d,$2c,$d8,$56), + ($a1,$0c,$7a,$37), ($a8,$01,$71,$39), ($b3,$16,$6c,$2b), ($ba,$1b,$67,$25), + ($85,$38,$56,$0f), ($8c,$35,$5d,$01), ($97,$22,$40,$13), ($9e,$2f,$4b,$1d), + ($e9,$64,$22,$47), ($e0,$69,$29,$49), ($fb,$7e,$34,$5b), ($f2,$73,$3f,$55), + ($cd,$50,$0e,$7f), ($c4,$5d,$05,$71), ($df,$4a,$18,$63), ($d6,$47,$13,$6d), + ($31,$dc,$ca,$d7), ($38,$d1,$c1,$d9), ($23,$c6,$dc,$cb), ($2a,$cb,$d7,$c5), + ($15,$e8,$e6,$ef), ($1c,$e5,$ed,$e1), ($07,$f2,$f0,$f3), ($0e,$ff,$fb,$fd), + ($79,$b4,$92,$a7), ($70,$b9,$99,$a9), ($6b,$ae,$84,$bb), ($62,$a3,$8f,$b5), + ($5d,$80,$be,$9f), ($54,$8d,$b5,$91), ($4f,$9a,$a8,$83), ($46,$97,$a3,$8d)); + + rcon: array[0..29] of cardinal= ( + $01, $02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, $d8, $ab, $4d, $9a, + $2f, $5e, $bc, $63, $c6, $97, $35, $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91); + +{==============================================================================} +type + PDWord = ^LongWord; + +procedure hperm_op(var a, t: integer; n, m: integer); +begin + t:= ((a shl (16 - n)) xor a) and m; + a:= a xor t xor (t shr (16 - n)); +end; + +procedure perm_op(var a, b, t: integer; n, m: integer); +begin + t:= ((a shr n) xor b) and m; + b:= b xor t; + a:= a xor (t shl n); +end; + +{==============================================================================} +function TSynaBlockCipher.GetSize: byte; +begin + Result := 8; +end; + +procedure TSynaBlockCipher.IncCounter; +var + i: integer; +begin + Inc(CV[GetSize]); + i:= GetSize -1; + while (i> 0) and (CV[i + 1] = #0) do + begin + Inc(CV[i]); + Dec(i); + end; +end; + +procedure TSynaBlockCipher.Reset; +begin + CV := IV; +end; + +procedure TSynaBlockCipher.InitKey(Key: AnsiString); +begin +end; + +procedure TSynaBlockCipher.SetIV(const Value: AnsiString); +begin + IV := PadString(Value, GetSize, #0); + Reset; +end; + +function TSynaBlockCipher.GetIV: AnsiString; +begin + Result := CV; +end; + +function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := InData; +end; + +function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s: ansistring; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + s := EncryptECB(s); + CV := s; + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString; +var + i: integer; + s, temp: ansistring; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + temp := s; + s := DecryptECB(s); + s := XorString(s, CV); + Result := Result + s; + CV := Temp; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to Length(Indata) do + begin + Temp := EncryptECB(CV); + c := AnsiChar(ord(InData[i]) xor ord(temp[1])); + Result := Result + c; + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString; +var + i: integer; + Temp: AnsiString; + c: AnsiChar; +begin + Result := ''; + for i:= 1 to length(Indata) do + begin + c:= Indata[i]; + Temp := EncryptECB(CV); + Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1])); + Delete(CV, 1, 1); + CV := CV + c; + end; +end; + +function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + CV := s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString; +var + i: integer; + S, Temp: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + s := copy(Indata, (i - 1) * bs + 1, bs); + Temp := s; + CV := EncryptECB(CV); + s := XorString(s, CV); + Result := result + s; + CV := temp; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + CV := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString; +var + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + Cv := EncryptECB(CV); + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, CV); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + CV := EncryptECB(CV); + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, CV); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + i: integer; + s: AnsiString; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString; +var + temp: AnsiString; + s: AnsiString; + i: integer; + l: integer; + bs: byte; +begin + Result := ''; + l := Length(InData); + bs := GetSize; + for i:= 1 to (l div bs) do + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (i - 1) * bs + 1, bs); + s := XorString(s, temp); + Result := Result + s; + end; + if (l mod bs)<> 0 then + begin + temp := EncryptECB(CV); + IncCounter; + s := copy(Indata, (l div bs) * bs + 1, l mod bs); + s := XorString(s, temp); + Result := Result + s; + end; +end; + +constructor TSynaBlockCipher.Create(Key: AnsiString); +begin + inherited Create; + InitKey(Key); + IV := StringOfChar(#0, GetSize); + IV := EncryptECB(IV); + Reset; +end; + +{==============================================================================} + +procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); +var + c, d, t, s, t2, i: integer; +begin + KeyB := PadString(KeyB, 8, #0); + c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24); + d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24); + perm_op(d,c,t,4,integer($0f0f0f0f)); + hperm_op(c,t,integer(-2),integer($cccc0000)); + hperm_op(d,t,integer(-2),integer($cccc0000)); + perm_op(d,c,t,1,integer($55555555)); + perm_op(c,d,t,8,integer($00ff00ff)); + perm_op(d,c,t,1,integer($55555555)); + d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or + ((c and integer($f0000000)) shr 4); + c:= c and $fffffff; + for i:= 0 to 15 do + begin + if shifts2[i]<> 0 then + begin + c:= ((c shr 2) or (c shl 26)); + d:= ((d shr 2) or (d shl 26)); + end + else + begin + c:= ((c shr 1) or (c shl 27)); + d:= ((d shr 1) or (d shl 27)); + end; + c:= c and $fffffff; + d:= d and $fffffff; + s:= des_skb[0,c and $3f] or + des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or + des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or + des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; + t:= des_skb[4,d and $3f] or + des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or + des_skb[6, (d shr 15) and $3f ] or + des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; + t2:= ((t shl 16) or (s and $ffff)); + KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); + t2:= ((s shr 16) or (t and integer($ffff0000))); + KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); + end; +end; + +function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 0; + while i< 32 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+2]; + t:= l xor KeyData[i+3]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i+4]; + t:= r xor KeyData[i+5]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i+6]; + t:= l xor KeyData[i+7]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Inc(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; +var + l, r, t, u: integer; + i: longint; +begin + r := Swapbytes(DecodeLongint(Indata, 1)); + l := Swapbytes(DecodeLongint(Indata, 5)); + t:= ((l shr 4) xor r) and $0f0f0f0f; + r:= r xor t; + l:= l xor (t shl 4); + t:= ((r shr 16) xor l) and $0000ffff; + l:= l xor t; + r:= r xor (t shl 16); + t:= ((l shr 2) xor r) and $33333333; + r:= r xor t; + l:= l xor (t shl 2); + t:= ((r shr 8) xor l) and $00ff00ff; + l:= l xor t; + r:= r xor (t shl 8); + t:= ((l shr 1) xor r) and $55555555; + r:= r xor t; + l:= l xor (t shl 1); + r:= (r shr 29) or (r shl 3); + l:= (l shr 29) or (l shl 3); + i:= 30; + while i> 0 do + begin + u:= r xor KeyData[i ]; + t:= r xor KeyData[i+1]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-2]; + t:= l xor KeyData[i-1]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= r xor KeyData[i-4]; + t:= r xor KeyData[i-3]; + t:= (t shr 4) or (t shl 28); + l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + u:= l xor KeyData[i-6]; + t:= l xor KeyData[i-5]; + t:= (t shr 4) or (t shl 28); + r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor + des_SPtrans[2,(u shr 10) and $3f] xor + des_SPtrans[4,(u shr 18) and $3f] xor + des_SPtrans[6,(u shr 26) and $3f] xor + des_SPtrans[1,(t shr 2) and $3f] xor + des_SPtrans[3,(t shr 10) and $3f] xor + des_SPtrans[5,(t shr 18) and $3f] xor + des_SPtrans[7,(t shr 26) and $3f]; + Dec(i,8); + end; + r:= (r shr 3) or (r shl 29); + l:= (l shr 3) or (l shl 29); + t:= ((r shr 1) xor l) and $55555555; + l:= l xor t; + r:= r xor (t shl 1); + t:= ((l shr 8) xor r) and $00ff00ff; + r:= r xor t; + l:= l xor (t shl 8); + t:= ((r shr 2) xor l) and $33333333; + l:= l xor t; + r:= r xor (t shl 2); + t:= ((l shr 16) xor r) and $0000ffff; + r:= r xor t; + l:= l xor (t shl 16); + t:= ((r shr 4) xor l) and $0f0f0f0f; + l:= l xor t; + r:= r xor (t shl 4); + Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); +end; + +{==============================================================================} + +procedure TSynaDes.InitKey(Key: AnsiString); +begin + Key := PadString(Key, 8, #0); + DoInit(Key,KeyData); +end; + +function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(InData,KeyData); +end; + +function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(Indata,KeyData); +end; + +{==============================================================================} + +procedure TSyna3Des.InitKey(Key: AnsiString); +var + Size: integer; + n: integer; +begin + Size := length(Key); + key := PadString(key, 3 * 8, #0); + DoInit(Copy(key, 1, 8),KeyData[0]); + DoInit(Copy(key, 9, 8),KeyData[1]); + if Size > 16 then + DoInit(Copy(key, 17, 8),KeyData[2]) + else + for n := 0 to high(KeyData[0]) do + KeyData[2][n] := Keydata[0][n]; +end; + +function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString; +begin + Result := EncryptBlock(Indata,KeyData[0]); + Result := DecryptBlock(Result,KeyData[1]); + Result := EncryptBlock(Result,KeyData[2]); +end; + +function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString; +begin + Result := DecryptBlock(InData,KeyData[2]); + Result := EncryptBlock(Result,KeyData[1]); + Result := DecryptBlock(Result,KeyData[0]); +end; + +{==============================================================================} + +procedure InvMixColumn(a: PByteArray; BC: byte); +var + j: longword; +begin + for j:= 0 to (BC-1) do + PDWord(@(a^[j*4]))^:= PDWord(@U1[a^[j*4+0]])^ + xor PDWord(@U2[a^[j*4+1]])^ + xor PDWord(@U3[a^[j*4+2]])^ + xor PDWord(@U4[a^[j*4+3]])^; +end; + +{==============================================================================} + +function TSynaAes.GetSize: byte; +begin + Result := 16; +end; + +procedure TSynaAes.InitKey(Key: AnsiString); +var + Size: integer; + KC, ROUNDS, j, r, t, rconpointer: longword; + tk: array[0..MAXKC-1,0..3] of byte; + //n: integer; +begin + FillChar(tk,Sizeof(tk),0); + //key must have at least 128 bits and max 256 bits + if length(key) < 16 then + key := PadString(key, 16, #0); + if length(key) > 32 then + delete(key, 33, maxint); + Size := length(Key); + Move(PAnsiChar(Key)^, tk, Size); + if Size<= 16 then + begin + KC:= 4; + Rounds:= 10; + end + else if Size<= 24 then + begin + KC:= 6; + Rounds:= 12; + end + else + begin + KC:= 8; + Rounds:= 14; + end; + numrounds:= rounds; + r:= 0; + t:= 0; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BC) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BC then + begin + t:= 0; + Inc(r); + end; + end; + rconpointer:= 0; + while (r< (rounds+1)) do + begin + tk[0,0]:= tk[0,0] xor S[tk[KC-1,1]]; + tk[0,1]:= tk[0,1] xor S[tk[KC-1,2]]; + tk[0,2]:= tk[0,2] xor S[tk[KC-1,3]]; + tk[0,3]:= tk[0,3] xor S[tk[KC-1,0]]; + tk[0,0]:= tk[0,0] xor rcon[rconpointer]; + Inc(rconpointer); + if KC<> 8 then + begin + for j:= 1 to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end + else + begin + for j:= 1 to ((KC div 2)-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + tk[KC div 2,0]:= tk[KC div 2,0] xor S[tk[KC div 2 - 1,0]]; + tk[KC div 2,1]:= tk[KC div 2,1] xor S[tk[KC div 2 - 1,1]]; + tk[KC div 2,2]:= tk[KC div 2,2] xor S[tk[KC div 2 - 1,2]]; + tk[KC div 2,3]:= tk[KC div 2,3] xor S[tk[KC div 2 - 1,3]]; + for j:= ((KC div 2) + 1) to (KC-1) do + PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; + end; + j:= 0; + while (j< KC) and (r< (rounds+1)) do + begin + while (j< KC) and (t< BC) do + begin + rk[r,t]:= PDWord(@tk[j])^; + Inc(j); + Inc(t); + end; + if t= BC then + begin + Inc(r); + t:= 0; + end; + end; + end; + Move(rk,drk,Sizeof(rk)); + for r:= 1 to (numrounds-1) do + InvMixColumn(@drk[r],BC); +end; + +function TSynaAes.EncryptECB(const InData: AnsiString): AnsiString; +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; + p: pointer; +begin + p := @a[0,0]; + move(pointer(InData)^, p^, 16); + for r:= 0 to (numrounds-2) do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[r,3]; + PDWord(@a[0])^:= PDWord(@T1[tempb[0,0]])^ xor + PDWord(@T2[tempb[1,1]])^ xor + PDWord(@T3[tempb[2,2]])^ xor + PDWord(@T4[tempb[3,3]])^; + PDWord(@a[1])^:= PDWord(@T1[tempb[1,0]])^ xor + PDWord(@T2[tempb[2,1]])^ xor + PDWord(@T3[tempb[3,2]])^ xor + PDWord(@T4[tempb[0,3]])^; + PDWord(@a[2])^:= PDWord(@T1[tempb[2,0]])^ xor + PDWord(@T2[tempb[3,1]])^ xor + PDWord(@T3[tempb[0,2]])^ xor + PDWord(@T4[tempb[1,3]])^; + PDWord(@a[3])^:= PDWord(@T1[tempb[3,0]])^ xor + PDWord(@T2[tempb[0,1]])^ xor + PDWord(@T3[tempb[1,2]])^ xor + PDWord(@T4[tempb[2,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[numrounds-1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[numrounds-1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[numrounds-1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[numrounds-1,3]; + a[0,0]:= T1[tempb[0,0],1]; + a[0,1]:= T1[tempb[1,1],1]; + a[0,2]:= T1[tempb[2,2],1]; + a[0,3]:= T1[tempb[3,3],1]; + a[1,0]:= T1[tempb[1,0],1]; + a[1,1]:= T1[tempb[2,1],1]; + a[1,2]:= T1[tempb[3,2],1]; + a[1,3]:= T1[tempb[0,3],1]; + a[2,0]:= T1[tempb[2,0],1]; + a[2,1]:= T1[tempb[3,1],1]; + a[2,2]:= T1[tempb[0,2],1]; + a[2,3]:= T1[tempb[1,3],1]; + a[3,0]:= T1[tempb[3,0],1]; + a[3,1]:= T1[tempb[0,1],1]; + a[3,2]:= T1[tempb[1,2],1]; + a[3,3]:= T1[tempb[2,3],1]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor rk[numrounds,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor rk[numrounds,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor rk[numrounds,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor rk[numrounds,3]; + + Result := StringOfChar(#0, 16); + move(p^, pointer(Result)^, 16); +end; + +function TSynaAes.DecryptECB(const InData: AnsiString): AnsiString; +var + r: longword; + tempb: array[0..MAXBC-1,0..3] of byte; + a: array[0..MAXBC,0..3] of byte; + p: pointer; +begin + p := @a[0,0]; + move(pointer(InData)^, p^, 16); + for r:= NumRounds downto 2 do + begin + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[r,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[r,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[r,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[r,3]; + PDWord(@a[0])^:= PDWord(@T5[tempb[0,0]])^ xor + PDWord(@T6[tempb[3,1]])^ xor + PDWord(@T7[tempb[2,2]])^ xor + PDWord(@T8[tempb[1,3]])^; + PDWord(@a[1])^:= PDWord(@T5[tempb[1,0]])^ xor + PDWord(@T6[tempb[0,1]])^ xor + PDWord(@T7[tempb[3,2]])^ xor + PDWord(@T8[tempb[2,3]])^; + PDWord(@a[2])^:= PDWord(@T5[tempb[2,0]])^ xor + PDWord(@T6[tempb[1,1]])^ xor + PDWord(@T7[tempb[0,2]])^ xor + PDWord(@T8[tempb[3,3]])^; + PDWord(@a[3])^:= PDWord(@T5[tempb[3,0]])^ xor + PDWord(@T6[tempb[2,1]])^ xor + PDWord(@T7[tempb[1,2]])^ xor + PDWord(@T8[tempb[0,3]])^; + end; + PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[1,0]; + PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[1,1]; + PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[1,2]; + PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[1,3]; + a[0,0]:= S5[tempb[0,0]]; + a[0,1]:= S5[tempb[3,1]]; + a[0,2]:= S5[tempb[2,2]]; + a[0,3]:= S5[tempb[1,3]]; + a[1,0]:= S5[tempb[1,0]]; + a[1,1]:= S5[tempb[0,1]]; + a[1,2]:= S5[tempb[3,2]]; + a[1,3]:= S5[tempb[2,3]]; + a[2,0]:= S5[tempb[2,0]]; + a[2,1]:= S5[tempb[1,1]]; + a[2,2]:= S5[tempb[0,2]]; + a[2,3]:= S5[tempb[3,3]]; + a[3,0]:= S5[tempb[3,0]]; + a[3,1]:= S5[tempb[2,1]]; + a[3,2]:= S5[tempb[1,2]]; + a[3,3]:= S5[tempb[0,3]]; + PDWord(@a[0])^:= PDWord(@a[0])^ xor drk[0,0]; + PDWord(@a[1])^:= PDWord(@a[1])^ xor drk[0,1]; + PDWord(@a[2])^:= PDWord(@a[2])^ xor drk[0,2]; + PDWord(@a[3])^:= PDWord(@a[3])^ xor drk[0,3]; + Result := StringOfChar(#0, 16); + move(p^, pointer(Result)^, 16); +end; + +{==============================================================================} + +function TestDes: boolean; +var + des: TSynaDes; + s, t: string; +const + key = '01234567'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSynaDes.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'c50ad028c6da9800'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSynaDes.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSynaDes.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSynaDes.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSynaDes.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSynaDes.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +function Test3Des: boolean; +var + des: TSyna3Des; + s, t: string; +const + key = '0123456789abcdefghijklmn'; + data1= '01234567'; + data2= '0123456789abcdefghij'; +begin + //ECB + des := TSyna3Des.Create(key); + try + s := des.EncryptECB(data1); + t := strtohex(s); + result := t = 'e0dee91008dc460c'; + s := des.DecryptECB(s); + result := result and (data1 = s); + finally + des.free; + end; + //CBC + des := TSyna3Des.Create(key); + try + s := des.EncryptCBC(data2); + t := strtohex(s); + result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a'); + des.Reset; + s := des.DecryptCBC(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-8bit + des := TSyna3Des.Create(key); + try + s := des.EncryptCFB8bit(data2); + t := strtohex(s); + result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8'); + des.Reset; + s := des.DecryptCFB8bit(s); + result := result and (data2 = s); + finally + des.free; + end; + //CFB-block + des := TSyna3Des.Create(key); + try + s := des.EncryptCFBblock(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671'); + des.Reset; + s := des.DecryptCFBblock(s); + result := result and (data2 = s); + finally + des.free; + end; + //OFB + des := TSyna3Des.Create(key); + try + s := des.EncryptOFB(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20'); + des.Reset; + s := des.DecryptOFB(s); + result := result and (data2 = s); + finally + des.free; + end; + //CTR + des := TSyna3Des.Create(key); + try + s := des.EncryptCTR(data2); + t := strtohex(s); + result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad'); + des.Reset; + s := des.DecryptCTR(s); + result := result and (data2 = s); + finally + des.free; + end; +end; + +function TestAes: boolean; +var + aes: TSynaAes; + s, t: string; +const + key1 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12; + data1= #$50#$68#$12#$A4#$5F#$08#$C8#$89#$B9#$7F#$59#$80#$03#$8B#$83#$59; + key2 = #$A0#$A1#$A2#$A3#$A5#$A6#$A7#$A8#$AA#$AB#$AC#$AD#$AF#$B0#$B1#$B2#$B4#$B5#$B6#$B7#$B9#$BA#$BB#$BC; + data2= #$4F#$1C#$76#$9D#$1E#$5B#$05#$52#$C7#$EC#$A8#$4D#$EA#$26#$A5#$49; + key3 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12#$14#$15#$16#$17#$19#$1A#$1B#$1C#$1E#$1F#$20#$21#$23#$24#$25#$26; + data3= #$5E#$25#$CA#$78#$F0#$DE#$55#$80#$25#$24#$D3#$8D#$A3#$FE#$44#$56; +begin + //ECB + aes := TSynaAes.Create(key1); + try + t := aes.EncryptECB(data1); + result := t = #$D8#$F5#$32#$53#$82#$89#$EF#$7D#$06#$B5#$06#$A4#$FD#$5B#$E9#$C9; + s := aes.DecryptECB(t); + result := result and (data1 = s); + finally + aes.free; + end; + aes := TSynaAes.Create(key2); + try + t := aes.EncryptECB(data2); + result := result and (t = #$F3#$84#$72#$10#$D5#$39#$1E#$23#$60#$60#$8E#$5A#$CB#$56#$05#$81); + s := aes.DecryptECB(t); + result := result and (data2 = s); + finally + aes.free; + end; + aes := TSynaAes.Create(key3); + try + t := aes.EncryptECB(data3); + result := result and (t = #$E8#$B7#$2B#$4E#$8B#$E2#$43#$43#$8C#$9F#$FF#$1F#$0E#$20#$58#$72); + s := aes.DecryptECB(t); + result := result and (data3 = s); + finally + aes.free; + end; +end; + +{==============================================================================} + +end. diff --git a/synadbg.pas b/synadbg.pas new file mode 100644 index 0000000..c587c3a --- /dev/null +++ b/synadbg.pas @@ -0,0 +1,156 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.002 | +|==============================================================================| +| Content: Socket debug tools | +|==============================================================================| +| Copyright (c)2008-2011, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2008-2011. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Socket debug tools) + +Routines for help with debugging of events on the Sockets. +} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synadbg; + +interface + +uses + blcksock, synsock, synautil, classes, sysutils, synafpc; + +type + TSynaDebug = class(TObject) + class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); + class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); + end; + +procedure AppendToLog(const value: Ansistring); + +var + LogFile: string; + +implementation + +procedure AppendToLog(const value: Ansistring); +var + st: TFileStream; + s: string; + h, m, ss, ms: word; + dt: Tdatetime; +begin + if fileexists(LogFile) then + st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) + else + st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); + try + st.Position := st.Size; + dt := now; + decodetime(dt, h, m, ss, ms); + s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; + WriteStrToStream(st, s); + finally + st.free; + end; +end; + +class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); +var + s: string; +begin + case Reason of + HR_ResolvingBegin: + s := 'HR_ResolvingBegin'; + HR_ResolvingEnd: + s := 'HR_ResolvingEnd'; + HR_SocketCreate: + s := 'HR_SocketCreate'; + HR_SocketClose: + s := 'HR_SocketClose'; + HR_Bind: + s := 'HR_Bind'; + HR_Connect: + s := 'HR_Connect'; + HR_CanRead: + s := 'HR_CanRead'; + HR_CanWrite: + s := 'HR_CanWrite'; + HR_Listen: + s := 'HR_Listen'; + HR_Accept: + s := 'HR_Accept'; + HR_ReadCount: + s := 'HR_ReadCount'; + HR_WriteCount: + s := 'HR_WriteCount'; + HR_Wait: + s := 'HR_Wait'; + HR_Error: + s := 'HR_Error'; + else + s := '-unknown-'; + end; + s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF; + AppendToLog(s); +end; + +class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); +var + s, d: Ansistring; +begin + setlength(s, len); + move(Buffer^, pointer(s)^, len); + if writing then + d := '-> ' + else + d := '<- '; + s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF; + AppendToLog(s); +end; + +initialization +begin + Logfile := changefileext(paramstr(0), '.slog'); +end; + +end. diff --git a/synafpc.pas b/synafpc.pas new file mode 100644 index 0000000..2742dea --- /dev/null +++ b/synafpc.pas @@ -0,0 +1,152 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.001 | +|==============================================================================| +| Content: Utils for FreePascal compatibility | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +unit synafpc; + +interface + +uses +{$IFDEF FPC} + {$IFNDEF ULTIBO}dynlibs,{$ENDIF} sysutils; +{$ELSE} + {$IFDEF MSWINDOWS} + Windows; + {$ELSE} + SysUtils; + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} +type + TLibHandle = {$IFNDEF ULTIBO}dynlibs.TLibHandle;{$ELSE}THandle;{$ENDIF} + +function LoadLibrary(ModuleName: PChar): TLibHandle; +function FreeLibrary(Module: TLibHandle): LongBool; +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +{$ELSE} //not FPC +type + {$IFDEF CIL} + TLibHandle = Integer; + PtrInt = Integer; + {$ELSE} + TLibHandle = HModule; + {$IFDEF WIN64} + PtrInt = NativeInt; + {$ELSE} + PtrInt = Integer; + {$ENDIF} + {$ENDIF} + {$IFDEF VER100} + LongWord = DWord; + {$ENDIF} +{$ENDIF} + +procedure Sleep(milliseconds: Cardinal); + + +implementation + +{==============================================================================} +{$IFDEF FPC} +function LoadLibrary(ModuleName: PChar): TLibHandle; +begin + Result := {$IFNDEF ULTIBO}dynlibs.LoadLibrary(Modulename);{$ELSE}-1;{$ENDIF} +end; + +function FreeLibrary(Module: TLibHandle): LongBool; +begin + Result := {$IFNDEF ULTIBO}dynlibs.UnloadLibrary(Module);{$ELSE}False;{$ENDIF} +end; + +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +begin +{$IFNDEF ULTIBO} + {$IFDEF OS2GCC} + Result := dynlibs.GetProcedureAddress(Module, '_' + Proc); + {$ELSE OS2GCC} + Result := dynlibs.GetProcedureAddress(Module, Proc); + {$ENDIF OS2GCC} +{$ELSE} + Result := nil; +{$ENDIF} +end; + +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +begin + Result := 0; +end; + +{$ELSE} +{$ENDIF} + +procedure Sleep(milliseconds: Cardinal); +begin +{$IFDEF MSWINDOWS} + {$IFDEF FPC} + sysutils.sleep(milliseconds); + {$ELSE} + windows.sleep(milliseconds); + {$ENDIF} +{$ELSE} + sysutils.sleep(milliseconds); +{$ENDIF} + +end; + +end. diff --git a/synaicnv.pas b/synaicnv.pas new file mode 100644 index 0000000..cbe0bfc --- /dev/null +++ b/synaicnv.pas @@ -0,0 +1,368 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.002 | +|==============================================================================| +| Content: ICONV support for Win32, OS/2, Linux and .NET | +|==============================================================================| +| Copyright (c)2004-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2004-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{:@abstract(LibIconv support) + +This unit is Pascal interface to LibIconv library for charset translations. +LibIconv is loaded dynamicly on-demand. If this library is not found in system, +requested LibIconv function just return errorcode. +} +unit synaicnv; + +interface + +uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} + synafpc, +{$IFNDEF MSWINDOWS} + {$IFNDEF FPC} + Libc, + {$ENDIF} + SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +const + {$IFNDEF MSWINDOWS} + {$IFDEF OS2} + DLLIconvName = 'iconv.dll'; + {$ELSE OS2} + DLLIconvName = 'libiconv.so'; + {$ENDIF OS2} + {$ELSE} + DLLIconvName = 'iconv.dll'; + {$ENDIF} + +type + size_t = Cardinal; +{$IFDEF CIL} + iconv_t = IntPtr; +{$ELSE} + iconv_t = Pointer; +{$ENDIF} + argptr = iconv_t; + +var + iconvLibHandle: TLibHandle = 0; + +function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t; +function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +function SynaIconvClose(var cd: iconv_t): integer; +function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; + +function IsIconvloaded: Boolean; +function InitIconvInterface: Boolean; +function DestroyIconvInterface: Boolean; + +const + ICONV_TRIVIALP = 0; // int *argument + ICONV_GET_TRANSLITERATE = 1; // int *argument + ICONV_SET_TRANSLITERATE = 2; // const int *argument + ICONV_GET_DISCARD_ILSEQ = 3; // int *argument + ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument + + +implementation + +uses SyncObjs; + +{$IFDEF CIL} + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_open')] + function _iconv_open(tocode: string; fromcode: string): iconv_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv')] + function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; + var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_close')] + function _iconv_close(cd: iconv_t): integer; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconvctl')] + function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; + +{$ELSE} +type + Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; + Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; + var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; + Ticonv_close = function(cd: iconv_t): integer; cdecl; + Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; +var + _iconv_open: Ticonv_open = nil; + _iconv: Ticonv = nil; + _iconv_close: Ticonv_close = nil; + _iconvctl: Ticonvctl = nil; +{$ENDIF} + + +var + IconvCS: TCriticalSection; + Iconvloaded: boolean = false; + +function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; +begin +{$IFDEF CIL} + try + Result := _iconv_open(tocode, fromcode); + except + on Exception do + Result := iconv_t(-1); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv_open) then + Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode)) + else + Result := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); +end; + +function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); +end; + +function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +var +{$IFDEF CIL} + ib, ob: IntPtr; + ibsave, obsave: IntPtr; + l: integer; +{$ELSE} + ib, ob: Pointer; +{$ENDIF} + ix, ox: size_t; +begin +{$IFDEF CIL} + l := Length(inbuf) * 4; + ibsave := IntPtr.Zero; + obsave := IntPtr.Zero; + try + ibsave := Marshal.StringToHGlobalAnsi(inbuf); + obsave := Marshal.AllocHGlobal(l); + ib := ibsave; + ob := obsave; + ix := Length(inbuf); + ox := l; + _iconv(cd, ib, ix, ob, ox); + Outbuf := Marshal.PtrToStringAnsi(obsave, l); + setlength(Outbuf, l - ox); + Result := Length(inbuf) - ix; + finally + Marshal.FreeCoTaskMem(ibsave); + Marshal.FreeHGlobal(obsave); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv) then + begin + setlength(Outbuf, Length(inbuf) * 4); + ib := Pointer(inbuf); + ob := Pointer(Outbuf); + ix := Length(inbuf); + ox := Length(Outbuf); + _iconv(cd, ib, ix, ob, ox); + setlength(Outbuf, cardinal(Length(Outbuf)) - ox); + Result := Cardinal(Length(inbuf)) - ix; + end + else + begin + Outbuf := ''; + Result := 0; + end; +{$ENDIF} +end; + +function SynaIconvClose(var cd: iconv_t): integer; +begin + if cd = iconv_t(-1) then + begin + Result := 0; + Exit; + end; +{$IFDEF CIL} + try; + Result := _iconv_close(cd) + except + on Exception do + Result := -1; + end; + cd := iconv_t(-1); +{$ELSE} + if InitIconvInterface and Assigned(_iconv_close) then + Result := _iconv_close(cd) + else + Result := -1; + cd := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; +begin +{$IFDEF CIL} + Result := _iconvctl(cd, request, argument) +{$ELSE} + if InitIconvInterface and Assigned(_iconvctl) then + Result := _iconvctl(cd, request, argument) + else + Result := 0; +{$ENDIF} +end; + +function InitIconvInterface: Boolean; +begin + IconvCS.Enter; + try + if not IsIconvloaded then + begin +{$IFDEF CIL} + IconvLibHandle := 1; +{$ELSE} + IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); +{$ENDIF} + if (IconvLibHandle <> 0) then + begin +{$IFNDEF CIL} + _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open'))); + _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); + _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); + _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl'))); +{$ENDIF} + Result := True; + Iconvloaded := True; + end + else + begin + //load failed! + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + IconvCS.Leave; + end; +end; + +function DestroyIconvInterface: Boolean; +begin + IconvCS.Enter; + try + Iconvloaded := false; + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; +{$IFNDEF CIL} + _iconv_open := nil; + _iconv := nil; + _iconv_close := nil; + _iconvctl := nil; +{$ENDIF} + finally + IconvCS.Leave; + end; + Result := True; +end; + +function IsIconvloaded: Boolean; +begin + Result := IconvLoaded; +end; + + initialization +begin + IconvCS:= TCriticalSection.Create; +end; + +finalization +begin +{$IFNDEF CIL} + DestroyIconvInterface; +{$ENDIF} + IconvCS.Free; +end; + +end. diff --git a/synaip.pas b/synaip.pas new file mode 100644 index 0000000..78184cb --- /dev/null +++ b/synaip.pas @@ -0,0 +1,422 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.002.001 | +|==============================================================================| +| Content: IP address support procedures and functions | +|==============================================================================| +| Copyright (c)2006-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(IP address support procedures and functions)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synaip; + +interface + +uses + SysUtils, SynaUtil; + +type +{:binary form of IPv6 address (for string conversion routines)} + TIp6Bytes = array [0..15] of Byte; +{:binary form of IPv6 address (for string conversion routines)} + TIp6Words = array [0..7] of Word; + +{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} +function IsIP(const Value: string): Boolean; + +{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} +function IsIP6(const Value: string): Boolean; + +{:Returns a string with the "Host" ip address converted to binary form.} +function IPToID(Host: string): string; + +{:Convert IPv6 address from their string form to binary byte array.} +function StrToIp6(value: string): TIp6Bytes; + +{:Convert IPv6 address from binary byte array to string form.} +function Ip6ToStr(value: TIp6Bytes): string; + +{:Convert IPv4 address from their string form to binary.} +function StrToIp(value: string): integer; + +{:Convert IPv4 address from binary to string form.} +function IpToStr(value: integer): string; + +{:Convert IPv4 address to reverse form.} +function ReverseIP(Value: String): String; + +{:Convert IPv6 address to reverse form.} +function ReverseIP6(const Value: String): String; + +{:Expand short form of IPv6 address to long form.} +function ExpandIP6(Value: String): String; + + +implementation + +{==============================================================================} + +function IsIP(const Value: string): Boolean; +var + TempIP: string; + function ByteIsOk(const Value: string): Boolean; + var + x, n: integer; + begin + x := StrToIntDef(Value, -1); + Result := (x >= 0) and (x < 256); + // X may be in correct range, but value still may not be correct value! + // i.e. "$80" + if Result then + for n := 1 to length(Value) do + if not (CharInSet(Value[n], ['0'..'9'])) then + begin + Result := False; + Break; + end; + end; +begin + TempIP := Value; + Result := False; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if ByteIsOk(TempIP) then + Result := True; +end; + +{==============================================================================} + +function IsIP6(const Value: string): Boolean; +var + TempIP: string; + s,t: string; + x: integer; + partcount: integer; + zerocount: integer; + First: Boolean; +begin + TempIP := Value; + Result := False; + if Value = '::' then + begin + Result := True; + Exit; + end; + partcount := 0; + zerocount := 0; + First := True; + while tempIP <> '' do + begin + s := fetch(TempIP, ':'); + if not(First) and (s = '') then + Inc(zerocount); + First := False; + if zerocount > 1 then + break; + Inc(partCount); + if s = '' then + Continue; + if partCount > 8 then + break; + if tempIP = '' then + begin + t := SeparateRight(s, '%'); + s := SeparateLeft(s, '%'); + x := StrToIntDef('$' + t, -1); + if (x < 0) or (x > $ffff) then + break; + end; + x := StrToIntDef('$' + s, -1); + if (x < 0) or (x > $ffff) then + break; + if tempIP = '' then + if not((PartCount = 1) and (ZeroCount = 0)) then + Result := True; + end; +end; + +{==============================================================================} +function IPToID(Host: string): String; +var + s: string; + i, x: Integer; +begin + Result := ''; + for x := 0 to 3 do + begin + s := Fetch(Host, '.'); + i := StrToIntDef(s, 0); + Result := Result + Char(i); + end; +end; + +{==============================================================================} + +function StrToIp(value: string): integer; +var + s: string; + i, x: Integer; +begin + Result := 0; + for x := 0 to 3 do + begin + s := Fetch(value, '.'); + i := StrToIntDef(s, 0); + Result := (256 * Result) + i; + end; +end; + +{==============================================================================} + +function IpToStr(value: integer): string; +var + x1, x2: word; + y1, y2: byte; +begin + Result := ''; + x1 := value shr 16; + x2 := value and $FFFF; + y1 := x1 div $100; + y2 := x1 mod $100; + Result := IntToStr(y1) + '.' + IntToStr(y2) + '.'; + y1 := x2 div $100; + y2 := x2 mod $100; + Result := Result + IntToStr(y1) + '.' + IntToStr(y2); +end; + +{==============================================================================} + +function ExpandIP6(Value: String): String; +var + n: integer; + s: String; + x: integer; +begin + Result := ''; + if value = '' then + exit; + x := countofchar(value, ':'); + if x > 7 then + exit; + if value[1] = ':' then + value := '0' + value; + if value[length(value)] = ':' then + value := value + '0'; + x := 8 - x; + s := ''; + for n := 1 to x do + s := s + ':0'; + s := s + ':'; + Result := replacestring(value, '::', s); +end; +{==============================================================================} + +function StrToIp6(Value: string): TIp6Bytes; +var + IPv6: TIp6Words; + Index: Integer; + n: integer; + b1, b2: byte; + s: string; + x: integer; +begin + for n := 0 to 15 do + Result[n] := 0; + for n := 0 to 7 do + Ipv6[n] := 0; + Index := 0; + Value := ExpandIP6(value); + if value = '' then + exit; + while Value <> '' do + begin + if Index > 7 then + Exit; + s := fetch(value, ':'); + if s = '@' then + break; + if s = '' then + begin + IPv6[Index] := 0; + end + else + begin + x := StrToIntDef('$' + s, -1); + if (x > 65535) or (x < 0) then + Exit; + IPv6[Index] := x; + end; + Inc(Index); + end; + for n := 0 to 7 do + begin + b1 := ipv6[n] div 256; + b2 := ipv6[n] mod 256; + Result[n * 2] := b1; + Result[(n * 2) + 1] := b2; + end; +end; + +{==============================================================================} +//based on routine by the Free Pascal development team +function Ip6ToStr(value: TIp6Bytes): string; +var + i, x: byte; + zr1,zr2: set of byte; + zc1,zc2: byte; + have_skipped: boolean; + ip6w: TIp6words; +begin + zr1 := []; + zr2 := []; + zc1 := 0; + zc2 := 0; + for i := 0 to 7 do + begin + x := i * 2; + ip6w[i] := value[x] * 256 + value[x + 1]; + if ip6w[i] = 0 then + begin + include(zr2, i); + inc(zc2); + end + else + begin + if zc1 < zc2 then + begin + zc1 := zc2; + zr1 := zr2; + zc2 := 0; + zr2 := []; + end; + end; + end; + if zc1 < zc2 then + begin + zr1 := zr2; + end; + SetLength(Result, 8*5-1); + SetLength(Result, 0); + have_skipped := false; + for i := 0 to 7 do + begin + if not(i in zr1) then + begin + if have_skipped then + begin + if Result = '' then + Result := '::' + else + Result := Result + ':'; + have_skipped := false; + end; + Result := Result + IntToHex(Ip6w[i], 1) + ':'; + end + else + begin + have_skipped := true; + end; + end; + if have_skipped then + if Result = '' then + Result := '::0' + else + Result := Result + ':'; + + if Result = '' then + Result := '::0'; + if not (7 in zr1) then + SetLength(Result, Length(Result)-1); + Result := LowerCase(result); +end; + +{==============================================================================} +function ReverseIP(Value: String): String; +var + x: Integer; +begin + Result := ''; + repeat + x := LastDelimiter('.', Value); + Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); + Delete(Value, x, Length(Value) - x + 1); + until x < 1; + if Length(Result) > 0 then + if Result[1] = '.' then + Delete(Result, 1, 1); +end; + +{==============================================================================} +function ReverseIP6(const Value: String): String; +var + ip6: TIp6bytes; + n: integer; + x, y: integer; +begin + ip6 := StrToIP6(Value); + x := ip6[15] div 16; + y := ip6[15] mod 16; + Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); + for n := 14 downto 0 do + begin + x := ip6[n] div 16; + y := ip6[n] mod 16; + Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); + end; +end; + +{==============================================================================} +end. diff --git a/synamisc.pas b/synamisc.pas new file mode 100644 index 0000000..c69c9ec --- /dev/null +++ b/synamisc.pas @@ -0,0 +1,482 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.001 | +|==============================================================================| +| Content: misc. procedures and functions | +|==============================================================================| +| Copyright (c)1999-2014, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Miscellaneous network based utilities)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + +{$IFDEF POSIX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + +{$TYPEDADDRESS OFF} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit synamisc; + +interface + +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} +{$ENDIF} + +uses + synautil, blcksock, SysUtils, Classes +{$IFDEF POSIX} + ,Types,Posix.Stdlib +{$ELSE} + {$IFDEF UNIX} + {$IFNDEF FPC} + , Libc + {$ENDIF} +{$ELSE} + {$IFDEF ULTIBO} + , GlobalConst, Iphlpapi + {$ELSE} + , Windows + {$ENDIF} +{$ENDIF} +; + + +const + lIPV4 = 1; + lIPV6 = 2; + +Type + {:@abstract(This record contains information about proxy settings.)} + TProxySetting = record + Host: string; + Port: string; + Bypass: string; + end; + +{:With this function you can turn on a computer on the network, if this computer + supports Wake-on-LAN feature. You need the MAC address + (network card identifier) of the computer. You can also assign a target IP + addres. If you do not specify it, then broadcast is used to deliver magic + wake-on-LAN packet. + However broadcasts work only on your local network. When you need to wake-up a + computer on another network, you must specify any existing IP addres on same + network segment as targeting computer.} +procedure WakeOnLan(MAC, IP: string); + +{:Autodetect current DNS servers used by the system. If more than one DNS server + is defined, then the result is comma-delimited.} +function GetDNS: string; + +{:Autodetect InternetExplorer proxy setting for given protocol. This function +works only on windows!} +function GetIEProxy(protocol: string): TProxySetting; + +{:Return all known IP addresses on the local system. Addresses are divided by +comma/comma-delimited.} +procedure GetLocalIPs(iplist: TStrings; ipfamily: Integer); overload; +function GetLocalIPs: string; overload + +implementation + +{==============================================================================} +procedure WakeOnLan(MAC, IP: string); +var + sock: TUDPBlockSocket; + HexMac: string; + data: string; + n: integer; + b: Byte; +begin + if MAC <> '' then + begin + MAC := ReplaceString(MAC, '-', ''); + MAC := ReplaceString(MAC, ':', ''); + if Length(MAC) < 12 then + Exit; + HexMac := ''; + for n := 0 to 5 do + begin + b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); + HexMac := HexMac + char(b); + end; + if IP = '' then + IP := cBroadcast; + sock := TUDPBlockSocket.Create; + try + sock.CreateSocket; + sock.EnableBroadcast(true); + sock.Connect(IP, '9'); + data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; + for n := 1 to 16 do + data := data + HexMac; + sock.SendString(data); + finally + sock.Free; + end; + end; +end; + +{==============================================================================} + +{$IFNDEF UNIX} +function GetDNSbyIpHlp: string; +{$IFDEF ULTIBO} +var + InfoSize: DWORD; + FixedInfo: TFixedInfo; + PDnsServer: PIP_ADDR_STRING; + ResultCode: DWORD; +begin + Result:=''; + + InfoSize:=SizeOf(TFixedInfo); + ResultCode:=GetNetworkParams(@FixedInfo,InfoSize); + if ResultCode <> ERROR_SUCCESS then Exit; + + Result:=FixedInfo.DnsServerList.IpAddress.S; + PDnsServer:=FixedInfo.DnsServerList.Next; + while PDnsServer <> nil do + begin + if Result <> '' then Result:=Result + ','; + Result:=Result + PDnsServer^.IPAddress.S; + PDnsServer:=PDnsServer.Next; + end; +end; +{$ELSE} +type + PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; + TIP_ADDRESS_STRING = array[0..15] of Ansichar; + PTIP_ADDR_STRING = ^TIP_ADDR_STRING; + TIP_ADDR_STRING = packed record + Next: PTIP_ADDR_STRING; + IpAddress: TIP_ADDRESS_STRING; + IpMask: TIP_ADDRESS_STRING; + Context: DWORD; + end; + PTFixedInfo = ^TFixedInfo; + TFixedInfo = packed record + HostName: array[1..128 + 4] of Ansichar; + DomainName: array[1..128 + 4] of Ansichar; + CurrentDNSServer: PTIP_ADDR_STRING; + DNSServerList: TIP_ADDR_STRING; + NodeType: UINT; + ScopeID: array[1..256 + 4] of Ansichar; + EnableRouting: UINT; + EnableProxy: UINT; + EnableDNS: UINT; + end; +const + IpHlpDLL = 'IPHLPAPI.DLL'; +var + IpHlpModule: THandle; + FixedInfo: PTFixedInfo; + InfoSize: Longint; + PDnsServer: PTIP_ADDR_STRING; + err: integer; + GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; +begin + InfoSize := 0; + Result := '...'; + IpHlpModule := LoadLibrary(IpHlpDLL); + if IpHlpModule = 0 then + exit; + try + GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); + if @GetNetworkParams = nil then + Exit; + err := GetNetworkParams(Nil, @InfoSize); + if err <> ERROR_BUFFER_OVERFLOW then + Exit; + Result := ''; + GetMem (FixedInfo, InfoSize); + try + err := GetNetworkParams(FixedInfo, @InfoSize); + if err <> ERROR_SUCCESS then + exit; + with FixedInfo^ do + begin + Result := DnsServerList.IpAddress; + PDnsServer := DnsServerList.Next; + while PDnsServer <> Nil do + begin + if Result <> '' then + Result := Result + ','; + Result := Result + PDnsServer^.IPAddress; + PDnsServer := PDnsServer.Next; + end; + end; + finally + FreeMem(FixedInfo); + end; + finally + FreeLibrary(IpHlpModule); + end; +end; + +function ReadReg(SubKey, Vn: PChar): string; +var + OpenKey: HKEY; + DataType, DataSize: integer; + Temp: array [0..2048] of char; +begin + Result := ''; + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, + KEY_READ, OpenKey) = ERROR_SUCCESS then + begin + DataType := REG_SZ; + DataSize := SizeOf(Temp); + if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then + SetString(Result, Temp, DataSize div SizeOf(Char) - 1); + RegCloseKey(OpenKey); + end; +end ; +{$ENDIF} +{$ENDIF} + +function GetDNS: string; +{$IFDEF ULTIBO} +begin + Result := GetDNSbyIpHlp; +end; +{$ELSE} +{$IFDEF UNIX} +var + l: TStringList; + n: integer; +begin + Result := ''; + l := TStringList.Create; + try + l.LoadFromFile('/etc/resolv.conf'); + for n := 0 to l.Count - 1 do + if Pos('NAMESERVER', uppercase(l[n])) = 1 then + begin + if Result <> '' then + Result := Result + ','; + Result := Result + SeparateRight(l[n], ' '); + end; + finally + l.Free; + end; +end; +{$ELSE} +const + NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; + NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; + W9xfix = 'System\CurrentControlSet\Services\MSTCP'; +begin + Result := GetDNSbyIpHlp; + if Result = '...' then + begin + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Result := ReadReg(NTdyn, 'NameServer'); + if result = '' then + Result := ReadReg(NTfix, 'NameServer'); + if result = '' then + Result := ReadReg(NTfix, 'DhcpNameServer'); + end + else + Result := ReadReg(W9xfix, 'NameServer'); + Result := ReplaceString(trim(Result), ' ', ','); + end; +end; +{$ENDIF} +{$ENDIF} + +{==============================================================================} + +function GetIEProxy(protocol: string): TProxySetting; +{$IFDEF ULTIBO} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; +end; +{$ELSE} +{$IFDEF UNIX} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; +end; +{$ELSE} +type + PInternetProxyInfo = ^TInternetProxyInfo; + TInternetProxyInfo = packed record + dwAccessType: DWORD; + lpszProxy: LPCSTR; + lpszProxyBypass: LPCSTR; + end; +const + INTERNET_OPTION_PROXY = 38; + INTERNET_OPEN_TYPE_PROXY = 3; + WininetDLL = 'WININET.DLL'; +var + WininetModule: THandle; + ProxyInfo: PInternetProxyInfo; + Err: Boolean; + Len: DWORD; + Proxy: string; + DefProxy: string; + ProxyList: TStringList; + n: integer; + InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; + lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; + WininetModule := LoadLibrary(WininetDLL); + if WininetModule = 0 then + exit; + try + InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); + if @InternetQueryOption = nil then + Exit; + + if protocol = '' then + protocol := 'http'; + Len := 4096; + GetMem(ProxyInfo, Len); + ProxyList := TStringList.Create; + try + Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); + if Err then + if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then + begin + ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); + Proxy := ''; + DefProxy := ''; + for n := 0 to ProxyList.Count -1 do + begin + if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then + begin + Proxy := SeparateRight(ProxyList[n], '='); + break; + end; + if Pos('=', ProxyList[n]) < 1 then + DefProxy := ProxyList[n]; + end; + if Proxy = '' then + Proxy := DefProxy; + if Proxy <> '' then + begin + Result.Host := Trim(SeparateLeft(Proxy, ':')); + Result.Port := Trim(SeparateRight(Proxy, ':')); + end; + Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); + end; + finally + ProxyList.Free; + FreeMem(ProxyInfo); + end; + finally + FreeLibrary(WininetModule); + end; +end; +{$ENDIF} +{$ENDIF} + +{==============================================================================} + +procedure GetLocalIPs(iplist: TStrings; ipfamily: Integer); +var + TcpSock: TTCPBlockSocket; +begin + TcpSock := TTCPBlockSocket.create; + case ipfamily of + 1 : TcpSock.family:=SF_IP4; + 2 : TcpSock.family:=SF_IP6; + end; + try + TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); + finally + TcpSock.Free; + end; +end; + +function GetLocalIPs: string; +var + TcpSock: TTCPBlockSocket; + ipList: TStringList; +begin + Result := ''; + ipList := TStringList.Create; + try + TcpSock := TTCPBlockSocket.create; + TcpSock.family:=SF_IP4; + try + TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); + Result := ipList.CommaText; + finally + TcpSock.Free; + end; + finally + ipList.Free; + end; +end; + +{==============================================================================} + +end. diff --git a/synaser.pas b/synaser.pas new file mode 100644 index 0000000..0ce9c63 --- /dev/null +++ b/synaser.pas @@ -0,0 +1,2788 @@ +{==============================================================================| +| Project : Ararat Synapse | 007.006.001 | +|==============================================================================| +| Content: Serial port support | +|==============================================================================| +| Copyright (c)2001-2017, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001-2017. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{: @abstract(Serial port communication library) +This unit contains a class that implements serial port communication + for Windows, Linux, Unix, MacOSx and Ultibo. This class provides numerous methods + with same name and functionality as methods of the Ararat Synapse TCP/IP library. + +The following is a small example how establish a connection by modem (in this +case with my USB modem): +@longcode(# + ser:=TBlockSerial.Create; + try + ser.Connect('COM3'); + ser.config(460800,8,'N',0,false,true); + ser.ATCommand('AT'); + if (ser.LastError <> 0) or (not ser.ATResult) then + Exit; + ser.ATConnect('ATDT+420971200111'); + if (ser.LastError <> 0) or (not ser.ATResult) then + Exit; + // you are now connected to a modem at +420971200111 + // you can transmit or receive data now + finally + ser.free; + end; +#) +} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +//Kylix does not known UNIX define +{$IFDEF LINUX} + {$IFNDEF UNIX} + {$DEFINE UNIX} + {$ENDIF} +{$ENDIF} + +{$IFDEF FPC} + {$MODE DELPHI} + {$IFDEF MSWINDOWS} + {$ASMMODE intel} + {$ENDIF} + {define working mode w/o LIBC for fpc} + {$DEFINE NO_LIBC} +{$ENDIF} +{$Q-} +{$H+} +{$M+} + +unit synaser; + +interface + +uses +{$IFNDEF MSWINDOWS} + {$IFDEF ULTIBO} + GlobalConst, + GlobalConfig, + Devices, + Serial, + {$ELSE} + {$IFNDEF NO_LIBC} + Libc, + KernelIoctl, + {$ELSE} + termio, baseunix, unix, + {$ENDIF} + {$IFNDEF FPC} + Types, + {$ENDIF} + {$ENDIF} +{$ELSE} + Windows, registry, + {$IFDEF FPC} + winver, + {$ENDIF} +{$ENDIF} + synafpc, + Classes, SysUtils, synautil; + +const + CR = #$0d; + LF = #$0a; + CRLF = CR + LF; + cSerialChunk = 8192; + + LockfileDirectory = '/var/lock'; {HGJ} + PortIsClosed = -1; {HGJ} + ErrAlreadyOwned = 9991; {HGJ} + ErrAlreadyInUse = 9992; {HGJ} + ErrWrongParameter = 9993; {HGJ} + ErrPortNotOpen = 9994; {HGJ} + ErrNoDeviceAnswer = 9995; {HGJ} + ErrMaxBuffer = 9996; + ErrTimeout = 9997; + ErrNotRead = 9998; + ErrFrame = 9999; + ErrOverrun = 10000; + ErrRxOver = 10001; + ErrRxParity = 10002; + ErrTxFull = 10003; + + dcb_Binary = $00000001; + dcb_ParityCheck = $00000002; + dcb_OutxCtsFlow = $00000004; + dcb_OutxDsrFlow = $00000008; + dcb_DtrControlMask = $00000030; + dcb_DtrControlDisable = $00000000; + dcb_DtrControlEnable = $00000010; + dcb_DtrControlHandshake = $00000020; + dcb_DsrSensivity = $00000040; + dcb_TXContinueOnXoff = $00000080; + dcb_OutX = $00000100; + dcb_InX = $00000200; + dcb_ErrorChar = $00000400; + dcb_NullStrip = $00000800; + dcb_RtsControlMask = $00003000; + dcb_RtsControlDisable = $00000000; + dcb_RtsControlEnable = $00001000; + dcb_RtsControlHandshake = $00002000; + dcb_RtsControlToggle = $00003000; + dcb_AbortOnError = $00004000; + dcb_Reserveds = $FFFF8000; + + {:stopbit value for 1 stopbit} + SB1 = 0; + {:stopbit value for 1.5 stopbit} + SB1andHalf = 1; + {:stopbit value for 2 stopbits} + SB2 = 2; + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +const + INVALID_HANDLE_VALUE = THandle(-1); + CS7fix = $0000020; +{$ENDIF} + +type + TDCB = record + DCBlength: DWORD; + BaudRate: DWORD; + Flags: Longint; + wReserved: Word; + XonLim: Word; + XoffLim: Word; + ByteSize: Byte; + Parity: Byte; + StopBits: Byte; + XonChar: CHAR; + XoffChar: CHAR; + ErrorChar: CHAR; + EofChar: CHAR; + EvtChar: CHAR; + wReserved1: Word; + end; + PDCB = ^TDCB; + +{$IFNDEF ULTIBO} +const +{$IFDEF UNIX} + {$IFDEF BSD} + MaxRates = 18; //MAC + {$ELSE} + MaxRates = 30; //UNIX + {$ENDIF} +{$ELSE} + MaxRates = 19; //WIN +{$ENDIF} + Rates: array[0..MaxRates, 0..1] of cardinal = + ( + (0, B0), + (50, B50), + (75, B75), + (110, B110), + (134, B134), + (150, B150), + (200, B200), + (300, B300), + (600, B600), + (1200, B1200), + (1800, B1800), + (2400, B2400), + (4800, B4800), + (9600, B9600), + (19200, B19200), + (38400, B38400), + (57600, B57600), + (115200, B115200), + (230400, B230400) +{$IFNDEF BSD} + ,(460800, B460800) + {$IFDEF UNIX} + ,(500000, B500000), + (576000, B576000), + (921600, B921600), + (1000000, B1000000), + (1152000, B1152000), + (1500000, B1500000), + (2000000, B2000000), + (2500000, B2500000), + (3000000, B3000000), + (3500000, B3500000), + (4000000, B4000000) + {$ENDIF} +{$ENDIF} + ); +{$ENDIF} +{$ENDIF} + +{$IFDEF BSD} +const // From fcntl.h + O_SYNC = $0080; { synchronous writes } +{$ENDIF} + +const + sOK = 0; + sErr = integer(-1); + +type + + {:Possible status event types for @link(THookSerialStatus)} + THookSerialReason = ( + HR_SerialClose, + HR_Connect, + HR_CanRead, + HR_CanWrite, + HR_ReadCount, + HR_WriteCount, + HR_Wait + ); + + {:procedural prototype for status event hooking} + THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason; + const Value: string) of object; + + {:@abstract(Exception type for SynaSer errors)} + ESynaSerError = class(Exception) + public + ErrorCode: integer; + ErrorMessage: string; + end; + + {:@abstract(Main class implementing all communication routines)} + TBlockSerial = class(TObject) + protected + FOnStatus: THookSerialStatus; + Fhandle: THandle; + FTag: integer; + FDevice: string; + FLastError: integer; + FLastErrorDesc: string; + FBuffer: AnsiString; + FRaiseExcept: boolean; + FRecvBuffer: integer; + FSendBuffer: integer; + FModemWord: integer; + FRTSToggle: Boolean; + FDeadlockTimeout: integer; + FInstanceActive: boolean; {HGJ} + FTestDSR: Boolean; + FTestCTS: Boolean; + FLastCR: Boolean; + FLastLF: Boolean; + FMaxLineLength: Integer; + FLinuxLock: Boolean; + FMaxSendBandwidth: Integer; + FNextSend: LongWord; + FMaxRecvBandwidth: Integer; + FNextRecv: LongWord; + FConvertLineEnd: Boolean; + FATResult: Boolean; + FAtTimeout: integer; + FInterPacketTimeout: Boolean; + FComNr: integer; +{$IFDEF MSWINDOWS} + FPortAddr: Word; + function CanEvent(Event: dword; Timeout: integer): boolean; + procedure DecodeCommError(Error: DWord); virtual; + {$IFDEF WIN32} + function GetPortAddr: Word; virtual; + function ReadTxEmpty(PortAddr: Word): Boolean; virtual; + {$ENDIF} +{$ENDIF} +{$IFDEF ULTIBO} + FSerialDevice: PSerialDevice; + procedure SetSizeSendBuffer(size: integer); virtual; +{$ENDIF} + procedure SetSizeRecvBuffer(size: integer); virtual; + function GetDSR: Boolean; virtual; + procedure SetDTRF(Value: Boolean); virtual; + function GetCTS: Boolean; virtual; + procedure SetRTSF(Value: Boolean); virtual; + function GetCarrier: Boolean; virtual; + function GetRing: Boolean; virtual; + procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual; + procedure GetComNr(Value: string); virtual; + function PreTestFailing: boolean; virtual;{HGJ} + function TestCtrlLine: Boolean; virtual; +{$IFDEF UNIX} + procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; + procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; + function ReadLockfile: integer; virtual; + function LockfileName: String; virtual; + procedure CreateLockfile(PidNr: integer); virtual; +{$ENDIF} + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual; + procedure SetBandwidth(Value: Integer); virtual; + public + {: data Control Block with communication parameters. Usable only when you + need to call API directly.} + DCB: Tdcb; +{$IFDEF UNIX} + TermiosStruc: termios; +{$ENDIF} + {:Object constructor.} + constructor Create; + {:Object destructor.} + destructor Destroy; override; + + {:Returns a string containing the version number of the library.} + class function GetVersion: string; virtual; + + {:Destroy handle in use. It close connection to serial port.} + procedure CloseSocket; virtual; + + {:Reconfigure communication parameters on the fly. You must be connected to + port before! + @param(baud Define connection speed. Baud rate can be from 50 to 4000000 + bits per second. (it depends on your hardware!)) + @param(bits Number of bits in communication.) + @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).) + @param(stop Define number of stopbits. Use constants @link(SB1), + @link(SB1andHalf) and @link(SB2).) + @param(softflow Enable XON/XOFF handshake.) + @param(hardflow Enable CTS/RTS handshake.)} + procedure Config(baud, bits: integer; parity: char; stop: integer; + softflow, hardflow: boolean); virtual; + + {:Connects to the port indicated by comport. Comport can be used in Windows + style (COM2), or in Linux style (/dev/ttyS1). When you use windows style + in Linux, then it will be converted to Linux name. And vice versa! However + you can specify any device name! (other device names then standart is not + converted!). In Ultibo you must use a serial device name (eg Serial0). + + After successfull connection the DTR signal is set (if you not set hardware + handshake, then the RTS signal is set, too!) + + Connection parameters is predefined by your system configuration. If you + need use another parameters, then you can use Config method after. + Notes: + + - Remember, the commonly used serial Laplink cable does not support + hardware handshake. + + - Before setting any handshake you must be sure that it is supported by + your hardware. + + - Some serial devices are slow. In some cases you must wait up to a few + seconds after connection for the device to respond. + + - when you connect to a modem device, then is best to test it by an empty + AT command. (call ATCommand('AT'))} + procedure Connect(comport: string); virtual; + + {:Set communication parameters from the DCB structure (the DCB structure is + simulated under Linux and Ultibo).} + procedure SetCommState; virtual; + + {:Read communication parameters into the DCB structure (DCB structure is + simulated under Linux and Ultibo).} + procedure GetCommState; virtual; + + {:Sends Length bytes of data from Buffer through the connected port.} + function SendBuffer(buffer: pointer; length: integer): integer; virtual; + + {:One data BYTE is sent.} + procedure SendByte(data: byte); virtual; + + {:Send the string in the data parameter. No terminator is appended by this + method. If you need to send a string with CR/LF terminator, you must append + the CR/LF characters to the data string! + + Since no terminator is appended, you can use this function for sending + binary data too.} + procedure SendString(data: AnsiString); virtual; + + {:send four bytes as integer.} + procedure SendInteger(Data: integer); virtual; + + {:send data as one block. Each block begins with integer value with Length + of block.} + procedure SendBlock(const Data: AnsiString); virtual; + + {:send content of stream from current position} + procedure SendStreamRaw(const Stream: TStream); virtual; + + {:send content of stream as block. see @link(SendBlock)} + procedure SendStream(const Stream: TStream); virtual; + + {:send content of stream as block, but this is compatioble with Indy library. + (it have swapped lenght of block). See @link(SendStream)} + procedure SendStreamIndy(const Stream: TStream); virtual; + + {:Waits until the allocated buffer is filled by received data. Returns number + of data bytes received, which equals to the Length value under normal + operation. If it is not equal, the communication channel is possibly broken. + + This method not using any internal buffering, like all others receiving + methods. You cannot freely combine this method with all others receiving + methods!} + function RecvBuffer(buffer: pointer; length: integer): integer; virtual; + + {:Method waits until data is received. If no data is received within + the Timeout (in milliseconds) period, @link(LastError) is set to + @link(ErrTimeout). This method is used to read any amount of data + (e. g. 1MB), and may be freely combined with all receviving methods what + have Timeout parameter, like the @link(RecvString), @link(RecvByte) or + @link(RecvTerminated) methods.} + function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual; + + {:It is like recvBufferEx, but data is readed to dynamicly allocated binary + string.} + function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual; + + {:Read all available data and return it in the function result string. This + function may be combined with @link(RecvString), @link(RecvByte) or related + methods.} + function RecvPacket(Timeout: Integer): AnsiString; virtual; + + {:Waits until one data byte is received which is returned as the function + result. If no data is received within the Timeout (in milliseconds) period, + @link(LastError) is set to @link(ErrTimeout).} + function RecvByte(timeout: integer): byte; virtual; + + {:This method waits until a terminated data string is received. This string + is terminated by the Terminator string. The resulting string is returned + without this termination string! If no data is received within the Timeout + (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).} + function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; + + {:This method waits until a terminated data string is received. The string + is terminated by a CR/LF sequence. The resulting string is returned without + the terminator (CR/LF)! If no data is received within the Timeout (in + milliseconds) period, @link(LastError) is set to @link(ErrTimeout). + + If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly + CR/LF. See the description of @link(ConvertLineEnd). + + This method serves for line protocol implementation and uses its own + buffers to maximize performance. Therefore do NOT use this method with the + @link(RecvBuffer) method to receive data as it may cause data loss.} + function RecvString(timeout: integer): AnsiString; virtual; + + {:Waits until four data bytes are received which is returned as the function + integer result. If no data is received within the Timeout (in milliseconds) period, + @link(LastError) is set to @link(ErrTimeout).} + function RecvInteger(Timeout: Integer): Integer; virtual; + + {:Waits until one data block is received. See @link(sendblock). If no data + is received within the Timeout (in milliseconds) period, @link(LastError) + is set to @link(ErrTimeout).} + function RecvBlock(Timeout: Integer): AnsiString; virtual; + + {:Receive all data to stream, until some error occured. (for example timeout)} + procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; + + {:receive requested count of bytes to stream} + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual; + + {:receive block of data to stream. (Data can be sended by @link(sendstream)} + procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; + + {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)} + procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; + + {:Returns the number of received bytes waiting for reading. 0 is returned + when there is no data waiting.} + function WaitingData: integer; virtual; + + {:Same as @link(WaitingData), but in respect to data in the internal + @link(LineBuffer).} + function WaitingDataEx: integer; virtual; + + {:Returns the number of bytes waiting to be sent in the output buffer. + 0 is returned when the output buffer is empty.} + function SendingData: integer; virtual; + + {:Enable or disable RTS driven communication (half-duplex). It can be used + to communicate with RS485 converters, or other special equipment. If you + enable this feature, the system automatically controls the RTS signal. + + Notes: + + - On Windows NT (or higher) ir RTS signal driven by system driver. + + - On Win9x family is used special code for waiting until last byte is + sended from your UART. + + - On Linux you must have kernel 2.1 or higher!} + procedure EnableRTSToggle(value: boolean); virtual; + + {:Waits until all data to is sent and buffers are emptied. + Warning: On Windows systems is this method returns when all buffers are + flushed to the serial port controller, before the last byte is sent!} + procedure Flush; virtual; + + {:Unconditionally empty all buffers. It is good when you need to interrupt + communication and for cleanups.} + procedure Purge; virtual; + + {:Returns @True, if you can from read any data from the port. Status is + tested for a period of time given by the Timeout parameter (in milliseconds). + If the value of the Timeout parameter is 0, the status is tested only once + and the function returns immediately. If the value of the Timeout parameter + is set to -1, the function returns only after it detects data on the port + (this may cause the process to hang).} + function CanRead(Timeout: integer): boolean; virtual; + + {:Returns @True, if you can write any data to the port (this function is not + sending the contents of the buffer). Status is tested for a period of time + given by the Timeout parameter (in milliseconds). If the value of + the Timeout parameter is 0, the status is tested only once and the function + returns immediately. If the value of the Timeout parameter is set to -1, + the function returns only after it detects that it can write data to + the port (this may cause the process to hang).} + function CanWrite(Timeout: integer): boolean; virtual; + + {:Same as @link(CanRead), but the test is against data in the internal + @link(LineBuffer) too.} + function CanReadEx(Timeout: integer): boolean; virtual; + + {:Returns the status word of the modem. Decoding the status word could yield + the status of carrier detect signaland other signals. This method is used + internally by the modem status reading properties. You usually do not need + to call this method directly.} + function ModemStatus: integer; virtual; + + {:Send a break signal to the communication device for Duration milliseconds.} + procedure SetBreak(Duration: integer); virtual; + + {:This function is designed to send AT commands to the modem. The AT command + is sent in the Value parameter and the response is returned in the function + return value (may contain multiple lines!). + If the AT command is processed successfully (modem returns OK), then the + @link(ATResult) property is set to True. + + This function is designed only for AT commands that return OK or ERROR + response! To call connection commands the @link(ATConnect) method. + Remember, when you connect to a modem device, it is in AT command mode. + Now you can send AT commands to the modem. If you need to transfer data to + the modem on the other side of the line, you must first switch to data mode + using the @link(ATConnect) method.} + function ATCommand(value: AnsiString): AnsiString; virtual; + + {:This function is used to send connect type AT commands to the modem. It is + for commands to switch to connected state. (ATD, ATA, ATO,...) + It sends the AT command in the Value parameter and returns the modem's + response (may be multiple lines - usually with connection parameters info). + If the AT command is processed successfully (the modem returns CONNECT), + then the ATResult property is set to @True. + + This function is designed only for AT commands which respond by CONNECT, + BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the + @link(ATCommand) method. + + The connect timeout is 90*@link(ATTimeout). If this command is successful + (@link(ATresult) is @true), then the modem is in data state. When you now + send or receive some data, it is not to or from your modem, but from the + modem on other side of the line. Now you can transfer your data. + If the connection attempt failed (@link(ATResult) is @False), then the + modem is still in AT command mode.} + function ATConnect(value: AnsiString): AnsiString; virtual; + + {:If you "manually" call API functions, forward their return code in + the SerialResult parameter to this function, which evaluates it and sets + @link(LastError) and @link(LastErrorDesc).} + function SerialCheck(SerialResult: integer): integer; virtual; + + {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure + raises an exception. This method is used internally. You may need it only + in special cases.} + procedure ExceptCheck; virtual; + + {:Set Synaser to error state with ErrNumber code. Usually used by internal + routines.} + procedure SetSynaError(ErrNumber: integer); virtual; + + {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} + procedure RaiseSynaError(ErrNumber: integer); virtual; +{$IFDEF UNIX} + function cpomComportAccessible: boolean; virtual;{HGJ} + procedure cpomReleaseComport; virtual; {HGJ} +{$ENDIF} + {:True device name of currently used port} + property Device: string read FDevice; + + {:Error code of last operation. Value is defined by the host operating + system, but value 0 is always OK.} + property LastError: integer read FLastError; + + {:Human readable description of LastError code.} + property LastErrorDesc: string read FLastErrorDesc; + + {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful} + property ATResult: Boolean read FATResult; + + {:Read the value of the RTS signal.} + property RTS: Boolean write SetRTSF; + + {:Indicates the presence of the CTS signal} + property CTS: boolean read GetCTS; + + {:Use this property to set the value of the DTR signal.} + property DTR: Boolean write SetDTRF; + + {:Exposes the status of the DSR signal.} + property DSR: boolean read GetDSR; + + {:Indicates the presence of the Carrier signal} + property Carrier: boolean read GetCarrier; + + {:Reflects the status of the Ring signal.} + property Ring: boolean read GetRing; + + {:indicates if this instance of SynaSer is active. (Connected to some port)} + property InstanceActive: boolean read FInstanceActive; {HGJ} + + {:Defines maximum bandwidth for all sending operations in bytes per second. + If this value is set to 0 (default), bandwidth limitation is not used.} + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + + {:Defines maximum bandwidth for all receiving operations in bytes per second. + If this value is set to 0 (default), bandwidth limitation is not used.} + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + + {:Defines maximum bandwidth for all sending and receiving operations + in bytes per second. If this value is set to 0 (default), bandwidth + limitation is not used.} + property MaxBandwidth: Integer Write SetBandwidth; + + {:Size of the Windows and Ultibo internal receive buffer. Default value is + usually 4096 or 2048 bytes respectively. Note: Valid only in Windows and + Ultibo versions!} + property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer; + +{$IFDEF ULTIBO} + {:Size of the Ultibo internal transmit buffer. Default value is usually + 2048 bytes. Note: Valid only in Ultibo version!} + property SizeSendBuffer: integer read FSendBuffer write SetSizeSendBuffer; +{$ENDIF} + published + {:Returns the descriptive text associated with ErrorCode. You need this + method only in special cases. Description of LastError is now accessible + through the LastErrorDesc property.} + class function GetErrorDesc(ErrorCode: integer): string; + + {:Freely usable property} + property Tag: integer read FTag write FTag; + + {:Contains the handle of the open communication port. + You may need this value to directly call communication functions outside + SynaSer.} + property Handle: THandle read Fhandle write FHandle; + + {:Internally used read buffer.} + property LineBuffer: AnsiString read FBuffer write FBuffer; + + {:If @true, communication errors raise exceptions. If @false (default), only + the @link(LastError) value is set.} + property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept; + + {:This event is triggered when the communication status changes. It can be + used to monitor communication status.} + property OnStatus: THookSerialStatus read FOnStatus write FOnStatus; + + {:If you set this property to @true, then the value of the DSR signal + is tested before every data transfer. It can be used to detect the presence + of a communications device.} + property TestDSR: boolean read FTestDSR write FTestDSR; + + {:If you set this property to @true, then the value of the CTS signal + is tested before every data transfer. It can be used to detect the presence + of a communications device. Warning: This property cannot be used if you + need hardware handshake!} + property TestCTS: boolean read FTestCTS write FTestCTS; + + {:Use this property you to limit the maximum size of LineBuffer + (as a protection against unlimited memory allocation for LineBuffer). + Default value is 0 - no limit.} + property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; + + {:This timeout value is used as deadlock protection when trying to send data + to (or receive data from) a device that stopped communicating during data + transmission (e.g. by physically disconnecting the device). + The timeout value is in milliseconds. The default value is 30,000 (30 seconds).} + property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout; + + {:If set to @true (default value), port locking is enabled (under Linux only). + WARNING: To use this feature, the application must run by a user with full + permission to the /var/lock directory!} + property LinuxLock: Boolean read FLinuxLock write FLinuxLock; + + {:Indicates if non-standard line terminators should be converted to a CR/LF pair + (standard DOS line terminator). If @TRUE, line terminators CR, single LF + or LF/CR are converted to CR/LF. Defaults to @FALSE. + This property has effect only on the behavior of the RecvString method.} + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Timeout for AT modem based operations} + property AtTimeout: integer read FAtTimeout Write FAtTimeout; + + {:If @true (default), then all timeouts is timeout between two characters. + If @False, then timeout is overall for whoole reading operation.} + property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + end; + +{:Returns list of existing computer serial ports. Working properly only in Windows and Ultibo!} +function GetSerialPortNames: string; + +implementation + +constructor TBlockSerial.Create; +begin + inherited create; + FRaiseExcept := false; + FHandle := INVALID_HANDLE_VALUE; + FDevice := ''; + FComNr:= PortIsClosed; {HGJ} + FInstanceActive:= false; {HGJ} + Fbuffer := ''; + FRTSToggle := False; + FMaxLineLength := 0; + FTestDSR := False; + FTestCTS := False; + FDeadlockTimeout := 30000; + FLinuxLock := True; + FMaxSendBandwidth := 0; + FNextSend := 0; + FMaxRecvBandwidth := 0; + FNextRecv := 0; + FConvertLineEnd := False; + SetSynaError(sOK); + {$IFDEF ULTIBO} + FRecvBuffer := SERIAL_RECEIVE_DEPTH_DEFAULT; + FSendBuffer := SERIAL_TRANSMIT_DEPTH_DEFAULT; + {$ELSE} + FRecvBuffer := 4096; + {$ENDIF} + FLastCR := False; + FLastLF := False; + FAtTimeout := 1000; + FInterPacketTimeout := True; +end; + +destructor TBlockSerial.Destroy; +begin + CloseSocket; + inherited destroy; +end; + +class function TBlockSerial.GetVersion: string; +begin + Result := 'SynaSer 7.6.0'; +end; + +procedure TBlockSerial.CloseSocket; +begin + if Fhandle <> INVALID_HANDLE_VALUE then + begin + Purge; + RTS := False; + DTR := False; + {$IFDEF ULTIBO} + SerialDeviceClose(FSerialDevice); + FSerialDevice := nil; + {$ELSE} + FileClose(FHandle); + {$ENDIF} + end; + if InstanceActive then + begin + {$IFDEF UNIX} + if FLinuxLock then + cpomReleaseComport; + {$ENDIF} + FInstanceActive:= false + end; + Fhandle := INVALID_HANDLE_VALUE; + FComNr:= PortIsClosed; + SetSynaError(sOK); + DoStatus(HR_SerialClose, FDevice); +end; + +{$IFDEF WIN32} +function TBlockSerial.GetPortAddr: Word; +begin + Result := 0; + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + EscapeCommFunction(FHandle, 10); + asm + MOV @Result, DX; + end; + end; +end; + +function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean; +begin + Result := True; + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + asm + MOV DX, PortAddr; + ADD DX, 5; + IN AL, DX; + AND AL, $40; + JZ @K; + MOV AL,1; + @K: MOV @Result, AL; + end; + end; +end; +{$ENDIF} + +procedure TBlockSerial.GetComNr(Value: string); +begin + FComNr := PortIsClosed; + if pos('COM', uppercase(Value)) = 1 then + FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1; + {$IFNDEF ULTIBO} + if pos('/DEV/TTYS', uppercase(Value)) = 1 then + FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1); + {$ELSE} + if pos(uppercase(SERIAL_NAME_PREFIX), uppercase(Value)) = 1 then + FComNr := StrToIntdef(copy(Value, Length(SERIAL_NAME_PREFIX) + 1, Length(Value) - Length(SERIAL_NAME_PREFIX)), PortIsClosed); + {$ENDIF} +end; + +procedure TBlockSerial.SetBandwidth(Value: Integer); +begin + MaxSendBandwidth := Value; + MaxRecvBandwidth := Value; +end; + +procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); +var + x: LongWord; + y: LongWord; +begin + if MaxB > 0 then + begin + y := GetTick; + if Next > y then + begin + x := Next - y; + if x > 0 then + begin + DoStatus(HR_Wait, IntToStr(x)); + sleep(x); + end; + end; + Next := GetTick + Trunc((Length / MaxB) * 1000); + end; +end; + +procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer; + softflow, hardflow: boolean); +begin + FillChar(dcb, SizeOf(dcb), 0); + GetCommState; + dcb.DCBlength := SizeOf(dcb); + dcb.BaudRate := baud; + dcb.ByteSize := bits; + case parity of + 'N', 'n': dcb.parity := 0; + 'O', 'o': dcb.parity := 1; + 'E', 'e': dcb.parity := 2; + 'M', 'm': dcb.parity := 3; + 'S', 's': dcb.parity := 4; + end; + dcb.StopBits := stop; + dcb.XonChar := #17; + dcb.XoffChar := #19; + dcb.XonLim := FRecvBuffer div 4; + dcb.XoffLim := FRecvBuffer div 4; + dcb.Flags := dcb_Binary; + if softflow then + dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; + if hardflow then + dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake + else + dcb.Flags := dcb.Flags or dcb_RtsControlEnable; + dcb.Flags := dcb.Flags or dcb_DtrControlEnable; + if dcb.Parity > 0 then + dcb.Flags := dcb.Flags or dcb_ParityCheck; + SetCommState; +end; + +procedure TBlockSerial.Connect(comport: string); +{$IFDEF MSWINDOWS} +var + CommTimeouts: TCommTimeouts; +{$ENDIF} +{$IFDEF ULTIBO} +var + ResultCode: LongWord; +{$ENDIF} +begin + // Is this TBlockSerial Instance already busy? + if InstanceActive then {HGJ} + begin {HGJ} + RaiseSynaError(ErrAlreadyInUse); + Exit; {HGJ} + end; {HGJ} + FBuffer := ''; + FDevice := comport; + GetComNr(comport); +{$IFDEF MSWINDOWS} + SetLastError (sOK); +{$ELSE} + {$IFDEF ULTIBO} + SetLastError (sOK); + {$ELSE} + {$IFNDEF FPC} + SetLastError (sOK); + {$ELSE} + fpSetErrno(sOK); + {$ENDIF} + {$ENDIF} +{$ENDIF} +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + if FComNr <> PortIsClosed then + FDevice := '/dev/ttyS' + IntToStr(FComNr); + // Comport already owned by another process? {HGJ} + if FLinuxLock then + if not cpomComportAccessible then + begin + RaiseSynaError(ErrAlreadyOwned); + Exit; + end; + {$IFNDEF FPC} + FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); + {$ELSE} + FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC)); + {$ENDIF} + if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! + SerialCheck(-1) + else + SerialCheck(0); + {$IFDEF UNIX} + if FLastError <> sOK then + if FLinuxLock then + cpomReleaseComport; + {$ENDIF} + ExceptCheck; + if FLastError <> sOK then + Exit; +{$ELSE} + if FComNr <> PortIsClosed then + FDevice := SERIAL_NAME_PREFIX + IntToStr(FComNr); + + // Find device + FSerialDevice := SerialDeviceFindByName(FDevice); + if FSerialDevice = nil then + SetSynaError(ErrWrongParameter) + else + SetSynaError(sOK); + ExceptCheck; + if FLastError <> sOK then + Exit; + + // Open device + ResultCode := SerialDeviceOpen(FSerialDevice, SERIAL_BAUD_RATE_DEFAULT, SERIAL_DATA_8BIT, SERIAL_STOP_1BIT, SERIAL_PARITY_NONE, SERIAL_FLOW_NONE, FRecvBuffer, FSendBuffer); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + SerialCheck(-1) + else + SerialCheck(0); + ExceptCheck; + if FLastError <> sOK then + Exit; + + FHandle := THandle(FSerialDevice); +{$ENDIF} +{$ELSE} + if FComNr <> PortIsClosed then + FDevice := '\\.\COM' + IntToStr(FComNr + 1); + FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE, + 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0)); + if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! + SerialCheck(-1) + else + SerialCheck(0); + ExceptCheck; + if FLastError <> sOK then + Exit; + SetCommMask(FHandle, 0); + SetupComm(Fhandle, FRecvBuffer, 0); + CommTimeOuts.ReadIntervalTimeout := MAXWORD; + CommTimeOuts.ReadTotalTimeoutMultiplier := 0; + CommTimeOuts.ReadTotalTimeoutConstant := 0; + CommTimeOuts.WriteTotalTimeoutMultiplier := 0; + CommTimeOuts.WriteTotalTimeoutConstant := 0; + SetCommTimeOuts(FHandle, CommTimeOuts); + {$IFDEF WIN32} + FPortAddr := GetPortAddr; + {$ENDIF} +{$ENDIF} + SetSynaError(sOK); + if not TestCtrlLine then {HGJ} + begin + SetSynaError(ErrNoDeviceAnswer); + {$IFDEF ULTIBO} + SerialDeviceClose(FSerialDevice); + FSerialDevice := nil; + {$ELSE} + FileClose(FHandle); {HGJ} + {$ENDIF} + {$IFDEF UNIX} + if FLinuxLock then + cpomReleaseComport; {HGJ} + {$ENDIF} {HGJ} + Fhandle := INVALID_HANDLE_VALUE; {HGJ} + FComNr:= PortIsClosed; {HGJ} + end + else + begin + FInstanceActive:= True; + RTS := True; + DTR := True; + Purge; + end; + ExceptCheck; + DoStatus(HR_Connect, FDevice); +end; + +function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer; +{$IFDEF MSWINDOWS} +var + Overlapped: TOverlapped; + x, y, Err: DWord; +{$ENDIF} +{$IFDEF ULTIBO} +var + ResultCode: LongWord; +{$ENDIF} +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + if FRTSToggle then + begin + Flush; + RTS := True; + end; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + result := FileWrite(Fhandle, Buffer^, Length); + serialcheck(result); +{$ELSE} + ResultCode := SerialDeviceWrite(FSerialDevice, buffer, length, SERIAL_WRITE_NONE, LongWord(Result)); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + SerialCheck(sErr) + else + SetSynaError(sOK); +{$ENDIF} +{$ELSE} + FillChar(Overlapped, Sizeof(Overlapped), 0); + SetSynaError(sOK); + y := 0; + if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + x := WaitForSingleObject(FHandle, FDeadlockTimeout); + if x = WAIT_TIMEOUT then + begin + PurgeComm(FHandle, PURGE_TXABORT); + SetSynaError(ErrTimeout); + end; + GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); + end + else + SetSynaError(y); + err := 0; + ClearCommError(FHandle, err, nil); + if err <> 0 then + DecodeCommError(err); +{$ENDIF} + if FRTSToggle then + begin + Flush; + CanWrite(255); + RTS := False; + end; + ExceptCheck; + DoStatus(HR_WriteCount, IntToStr(Result)); +end; + +procedure TBlockSerial.SendByte(data: byte); +begin + SendBuffer(@Data, 1); +end; + +procedure TBlockSerial.SendString(data: AnsiString); +begin + SendBuffer(Pointer(Data), Length(Data)); +end; + +procedure TBlockSerial.SendInteger(Data: integer); +begin + SendBuffer(@data, SizeOf(Data)); +end; + +procedure TBlockSerial.SendBlock(const Data: AnsiString); +begin + SendInteger(Length(data)); + SendString(Data); +end; + +procedure TBlockSerial.SendStreamRaw(const Stream: TStream); +var + si: integer; + x, y, yr: integer; + s: AnsiString; +begin + si := Stream.Size - Stream.Position; + x := 0; + while x < si do + begin + y := si - x; + if y > cSerialChunk then + y := cSerialChunk; + Setlength(s, y); + yr := Stream.read(PAnsiChar(s)^, y); + if yr > 0 then + begin + SetLength(s, yr); + SendString(s); + Inc(x, yr); + end + else + break; + end; +end; + +procedure TBlockSerial.SendStreamIndy(const Stream: TStream); +var + si: integer; +begin + si := Stream.Size - Stream.Position; + si := Swapbytes(si); + SendInteger(si); + SendStreamRaw(Stream); +end; + +procedure TBlockSerial.SendStream(const Stream: TStream); +var + si: integer; +begin + si := Stream.Size - Stream.Position; + SendInteger(si); + SendStreamRaw(Stream); +end; + +function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + result := FileRead(FHandle, Buffer^, length); + serialcheck(result); +{$ELSE} +var + ResultCode: LongWord; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + ResultCode := SerialDeviceRead(FSerialDevice, buffer, length, SERIAL_READ_NONE, LongWord(Result)); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + SerialCheck(sErr) + else + SetSynaError(sOK); +{$ENDIF} +{$ELSE} +var + Overlapped: TOverlapped; + x, y, Err: DWord; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); + FillChar(Overlapped, Sizeof(Overlapped), 0); + SetSynaError(sOK); + y := 0; + if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + x := WaitForSingleObject(FHandle, FDeadlockTimeout); + if x = WAIT_TIMEOUT then + begin + PurgeComm(FHandle, PURGE_RXABORT); + SetSynaError(ErrTimeout); + end; + GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); + end + else + SetSynaError(y); + err := 0; + ClearCommError(FHandle, err, nil); + if err <> 0 then + DecodeCommError(err); +{$ENDIF} + ExceptCheck; + DoStatus(HR_ReadCount, IntToStr(Result)); +end; + +function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; +var + s: AnsiString; + rl, l: integer; + ti: LongWord; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + rl := 0; + repeat + ti := GetTick; + s := RecvPacket(Timeout); + l := System.Length(s); + if (rl + l) > Length then + l := Length - rl; + Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + rl := rl + l; + if FLastError <> sOK then + Break; + if rl >= Length then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + SetSynaError(ErrTimeout); + Break; + end; + end; + until False; + delete(s, 1, l); + FBuffer := s; + Result := rl; +end; + +function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if Length > 0 then + begin + Setlength(Result, Length); + x := RecvBufferEx(PAnsiChar(Result), Length , Timeout); + if FLastError = sOK then + SetLength(Result, x) + else + Result := ''; + end; +end; + +function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if FBuffer <> '' then + begin + Result := FBuffer; + FBuffer := ''; + end + else + begin + //not drain CPU on large downloads... + Sleep(0); + x := WaitingData; + if x > 0 then + begin + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + end + else + begin + if CanRead(Timeout) then + begin + x := WaitingData; + if x = 0 then + SetSynaError(ErrTimeout); + if x > 0 then + begin + SetLength(Result, x); + x := RecvBuffer(Pointer(Result), x); + if x >= 0 then + SetLength(Result, x); + end; + end + else + SetSynaError(ErrTimeout); + end; + end; + ExceptCheck; +end; + + +function TBlockSerial.RecvByte(timeout: integer): byte; +begin + Result := 0; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + if FBuffer = '' then + FBuffer := RecvPacket(Timeout); + if (FLastError = sOK) and (FBuffer <> '') then + begin + Result := Ord(FBuffer[1]); + System.Delete(FBuffer, 1, 1); + end; + ExceptCheck; +end; + +function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; +var + x: Integer; + s: AnsiString; + l: Integer; + CorCRLF: Boolean; + t: ansistring; + tl: integer; + ti: LongWord; +begin + Result := ''; + if PreTestFailing then {HGJ} + Exit; {HGJ} + SetSynaError(sOK); + l := system.Length(Terminator); + if l = 0 then + Exit; + tl := l; + CorCRLF := FConvertLineEnd and (Terminator = CRLF); + s := ''; + x := 0; + repeat + ti := GetTick; + //get rest of FBuffer or incomming new data... + s := s + RecvPacket(Timeout); + if FLastError <> sOK then + Break; + x := 0; + if Length(s) > 0 then + if CorCRLF then + begin + if FLastCR and (s[1] = LF) then + Delete(s, 1, 1); + if FLastLF and (s[1] = CR) then + Delete(s, 1, 1); + FLastCR := False; + FLastLF := False; + t := ''; + x := PosCRLF(s, t); + tl := system.Length(t); + if t = CR then + FLastCR := True; + if t = LF then + FLastLF := True; + end + else + begin + x := pos(Terminator, s); + tl := l; + end; + if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then + begin + SetSynaError(ErrMaxBuffer); + Break; + end; + if x > 0 then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + SetSynaError(ErrTimeout); + Break; + end; + end; + until False; + if x > 0 then + begin + Result := Copy(s, 1, x - 1); + System.Delete(s, 1, x + tl - 1); + end; + FBuffer := s; + ExceptCheck; +end; + + +function TBlockSerial.RecvString(Timeout: Integer): AnsiString; +var + s: AnsiString; +begin + Result := ''; + s := RecvTerminated(Timeout, #13 + #10); + if FLastError = sOK then + Result := s; +end; + +function TBlockSerial.RecvInteger(Timeout: Integer): Integer; +var + s: AnsiString; +begin + Result := 0; + s := RecvBufferStr(4, Timeout); + if FLastError = 0 then + Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; +end; + +function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString; +var + x: integer; +begin + Result := ''; + x := RecvInteger(Timeout); + if FLastError = 0 then + Result := RecvBufferStr(x, Timeout); +end; + +procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer); +var + s: AnsiString; +begin + repeat + s := RecvPacket(Timeout); + if FLastError = 0 then + WriteStrToStream(Stream, s); + until FLastError <> 0; +end; + +procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +var + s: AnsiString; + n: integer; +begin + for n := 1 to (Size div cSerialChunk) do + begin + s := RecvBufferStr(cSerialChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(PAnsichar(s)^, cSerialChunk); + end; + n := Size mod cSerialChunk; + if n > 0 then + begin + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(PAnsichar(s)^, n); + end; +end; + +procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + x := SwapBytes(x); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +function TBlockSerial.WaitingData: integer; +begin + {$IFNDEF FPC} + serialcheck(ioctl(FHandle, FIONREAD, @result)); + {$ELSE} + serialcheck(fpIoctl(FHandle, FIONREAD, @result)); + {$ENDIF} + if FLastError <> 0 then + Result := 0; + ExceptCheck; +end; +{$ELSE} +function TBlockSerial.WaitingData: integer; +var + ResultCode: LongWord; +begin + ResultCode := SerialDeviceRead(FSerialDevice, @ResultCode, SizeOf(ResultCode), SERIAL_READ_PEEK_BUFFER, LongWord(Result)); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + begin + SerialCheck(sErr); + Result := 0; + end + else + SetSynaError(sOK); + ExceptCheck; +end; +{$ENDIF} +{$ELSE} +function TBlockSerial.WaitingData: integer; +var + stat: TComStat; + err: DWORD; +begin + err := 0; + if ClearCommError(FHandle, err, @stat) then + begin + SetSynaError(sOK); + Result := stat.cbInQue; + end + else + begin + SerialCheck(sErr); + Result := 0; + end; + ExceptCheck; +end; +{$ENDIF} + +function TBlockSerial.WaitingDataEx: integer; +begin + if FBuffer <> '' then + Result := Length(FBuffer) + else + Result := Waitingdata; +end; + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +function TBlockSerial.SendingData: integer; +begin + SetSynaError(sOK); + Result := 0; +end; +{$ELSE} +function TBlockSerial.SendingData: integer; +var + ResultCode: LongWord; +begin + ResultCode := SerialDeviceWrite(FSerialDevice, @ResultCode, SizeOf(ResultCode), SERIAL_WRITE_PEEK_BUFFER, LongWord(Result)); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + begin + SerialCheck(sErr); + Result := 0; + end + else + begin + SetSynaError(sOK); + Result := FSendBuffer - Result; + end; + ExceptCheck; +end; +{$ENDIF} +{$ELSE} +function TBlockSerial.SendingData: integer; +var + stat: TComStat; + err: DWORD; +begin + SetSynaError(sOK); + err := 0; + if not ClearCommError(FHandle, err, @stat) then + serialcheck(sErr); + ExceptCheck; + result := stat.cbOutQue; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios); +var + n: integer; + x: cardinal; +begin + //others + cfmakeraw(term); + term.c_cflag := term.c_cflag or CREAD; + term.c_cflag := term.c_cflag or CLOCAL; + term.c_cflag := term.c_cflag or HUPCL; + //hardware handshake + if (dcb.flags and dcb_RtsControlHandshake) > 0 then + term.c_cflag := term.c_cflag or CRTSCTS + else + term.c_cflag := term.c_cflag and (not CRTSCTS); + //software handshake + if (dcb.flags and dcb_OutX) > 0 then + term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY + else + term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY)); + //size of byte + term.c_cflag := term.c_cflag and (not CSIZE); + case dcb.bytesize of + 5: + term.c_cflag := term.c_cflag or CS5; + 6: + term.c_cflag := term.c_cflag or CS6; + 7: + {$IFDEF FPC} + term.c_cflag := term.c_cflag or CS7; + {$ELSE} + term.c_cflag := term.c_cflag or CS7fix; + {$ENDIF} + 8: + term.c_cflag := term.c_cflag or CS8; + end; + //parity + if (dcb.flags and dcb_ParityCheck) > 0 then + term.c_cflag := term.c_cflag or PARENB + else + term.c_cflag := term.c_cflag and (not PARENB); + case dcb.parity of + 1: //'O' + term.c_cflag := term.c_cflag or PARODD; + 2: //'E' + term.c_cflag := term.c_cflag and (not PARODD); + end; + //stop bits + if dcb.stopbits > 0 then + term.c_cflag := term.c_cflag or CSTOPB + else + term.c_cflag := term.c_cflag and (not CSTOPB); + //set baudrate; + x := 0; + for n := 0 to Maxrates do + if rates[n, 0] = dcb.BaudRate then + begin + x := rates[n, 1]; + break; + end; + cfsetospeed(term, x); + cfsetispeed(term, x); +end; + +procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB); +var + n: integer; + x: cardinal; +begin + //set baudrate; + dcb.baudrate := 0; + {$IFDEF FPC} + //why FPC not have cfgetospeed??? + x := term.c_oflag and $0F; + {$ELSE} + x := cfgetospeed(term); + {$ENDIF} + for n := 0 to Maxrates do + if rates[n, 1] = x then + begin + dcb.baudrate := rates[n, 0]; + break; + end; + //hardware handshake + if (term.c_cflag and CRTSCTS) > 0 then + dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow + else + dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow)); + //software handshake + if (term.c_cflag and IXOFF) > 0 then + dcb.flags := dcb.flags or dcb_OutX or dcb_InX + else + dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX)); + //size of byte + case term.c_cflag and CSIZE of + CS5: + dcb.bytesize := 5; + CS6: + dcb.bytesize := 6; + CS7fix: + dcb.bytesize := 7; + CS8: + dcb.bytesize := 8; + end; + //parity + if (term.c_cflag and PARENB) > 0 then + dcb.flags := dcb.flags or dcb_ParityCheck + else + dcb.flags := dcb.flags and (not dcb_ParityCheck); + dcb.parity := 0; + if (term.c_cflag and PARODD) > 0 then + dcb.parity := 1 + else + dcb.parity := 2; + //stop bits + if (term.c_cflag and CSTOPB) > 0 then + dcb.stopbits := 2 + else + dcb.stopbits := 0; +end; +{$ENDIF} +{$ENDIF} + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +procedure TBlockSerial.SetCommState; +begin + DcbToTermios(dcb, termiosstruc); + SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); + ExceptCheck; +end; +{$ELSE} +procedure TBlockSerial.SetCommState; +var + ResultCode: LongWord; + Properties: TSerialProperties; +begin + FillChar(Properties, SizeOf(TSerialProperties), 0); + + // Baud Rate + Properties.BaudRate := DCB.BaudRate; + + // Data bits + Properties.DataBits := SERIAL_DATA_8BIT; + case DCB.ByteSize of + 7: Properties.DataBits := SERIAL_DATA_7BIT; + 6: Properties.DataBits := SERIAL_DATA_6BIT; + 5: Properties.DataBits := SERIAL_DATA_5BIT; + end; + + // Stop Bits + Properties.StopBits := SERIAL_STOP_1BIT; + case DCB.StopBits of + 2: Properties.StopBits := SERIAL_STOP_2BIT; + 1: Properties.StopBits := SERIAL_STOP_1BIT5; + end; + + // Parity + Properties.Parity := SERIAL_PARITY_NONE; + case DCB.Parity of + 1: Properties.Parity := SERIAL_PARITY_ODD; + 2: Properties.Parity := SERIAL_PARITY_EVEN; + 3: Properties.Parity := SERIAL_PARITY_MARK; + 4: Properties.Parity := SERIAL_PARITY_SPACE; + end; + + // Flow Control + Properties.FlowControl := SERIAL_FLOW_NONE; + if (DCB.Flags and dcb_RtsControlHandshake) <> 0 then + Properties.FlowControl := SERIAL_FLOW_RTS_CTS + else if (DCB.Flags and dcb_DtrControlHandshake) <> 0 then + Properties.FlowControl := SERIAL_FLOW_DSR_DTR; + + // Receive and Send Buffer + Properties.ReceiveDepth := FRecvBuffer; + Properties.TransmitDepth := FSendBuffer; + + // Set device properties + ResultCode := SerialDeviceSetProperties(FSerialDevice, @Properties); + + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + SerialCheck(sErr) + else + SetSynaError(sOK); + ExceptCheck; +end; +{$ENDIF} +{$ELSE} +procedure TBlockSerial.SetCommState; +begin + SetSynaError(sOK); + if not windows.SetCommState(Fhandle, dcb) then + SerialCheck(sErr); + ExceptCheck; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +procedure TBlockSerial.GetCommState; +begin + SerialCheck(tcgetattr(FHandle, termiosstruc)); + ExceptCheck; + TermiostoDCB(termiosstruc, dcb); +end; +{$ELSE} +procedure TBlockSerial.GetCommState; +var + ResultCode: LongWord; + Properties: TSerialProperties; +begin + ResultCode := SerialDeviceGetProperties(FSerialDevice, @Properties); + SetLastError(ResultCode); + if ResultCode <> ERROR_SUCCESS then + SerialCheck(sErr) + else + begin + SetSynaError(sOK); + + // Get DCB + DCB.DCBlength := SizeOf(Tdcb); + + // Baud Rate + DCB.BaudRate := Properties.BaudRate; + + // Flags + DCB.Flags := 0; + if Properties.Parity <> SERIAL_PARITY_NONE then + DCB.Flags := DCB.Flags or dcb_ParityCheck; + if Properties.FlowControl = SERIAL_FLOW_RTS_CTS then + DCB.Flags := DCB.Flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow + else if Properties.FlowControl = SERIAL_FLOW_DSR_DTR then + DCB.Flags := DCB.Flags or dcb_DtrControlHandshake or dcb_OutxDsrFlow; + + // Data Bits + case Properties.DataBits of + SERIAL_DATA_8BIT: DCB.ByteSize := 8; + SERIAL_DATA_7BIT: DCB.ByteSize := 7; + SERIAL_DATA_6BIT: DCB.ByteSize := 6; + SERIAL_DATA_5BIT: DCB.ByteSize := 5; + end; + + // Parity + case Properties.Parity of + SERIAL_PARITY_NONE: DCB.Parity := 0; + SERIAL_PARITY_ODD: DCB.Parity := 1; + SERIAL_PARITY_EVEN: DCB.Parity := 2; + SERIAL_PARITY_MARK: DCB.Parity := 3; + SERIAL_PARITY_SPACE: DCB.Parity := 4; + end; + + // Stop Bits + case Properties.StopBits of + SERIAL_STOP_1BIT: DCB.StopBits := 0; + SERIAL_STOP_2BIT: DCB.StopBits := 2; + SERIAL_STOP_1BIT5: DCB.StopBits := 1; + end; + end; + ExceptCheck; +end; +{$ENDIF} +{$ELSE} +procedure TBlockSerial.GetCommState; +begin + SetSynaError(sOK); + if not windows.GetCommState(Fhandle, dcb) then + SerialCheck(sErr); + ExceptCheck; +end; +{$ENDIF} + +procedure TBlockSerial.SetSizeRecvBuffer(size: integer); +begin +{$IFDEF MSWINDOWS} + SetupComm(Fhandle, size, 0); + GetCommState; + dcb.XonLim := size div 4; + dcb.XoffLim := size div 4; + SetCommState; +{$ENDIF} + FRecvBuffer := size; +end; + +{$IFDEF ULTIBO} +procedure TBlockSerial.SetSizeSendBuffer(size: integer); +begin + FSendBuffer := size; +end; +{$ENDIF} + +function TBlockSerial.GetDSR: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + Result := (FModemWord and TIOCM_DSR) > 0; +{$ELSE} + Result := (FModemWord and SERIAL_STATUS_DSR) <> 0; +{$ENDIF} +{$ELSE} + Result := (FModemWord and MS_DSR_ON) > 0; +{$ENDIF} +end; + +procedure TBlockSerial.SetDTRF(Value: Boolean); +begin +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + ModemStatus; + if Value then + FModemWord := FModemWord or TIOCM_DTR + else + FModemWord := FModemWord and not TIOCM_DTR; + {$IFNDEF FPC} + ioctl(FHandle, TIOCMSET, @FModemWord); + {$ELSE} + fpioctl(FHandle, TIOCMSET, @FModemWord); + {$ENDIF} +{$ELSE} + if Value then + SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) or SERIAL_STATUS_DTR) + else + SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) and not(SERIAL_STATUS_DTR)); +{$ENDIF} +{$ELSE} + if Value then + EscapeCommFunction(FHandle, SETDTR) + else + EscapeCommFunction(FHandle, CLRDTR); +{$ENDIF} +end; + +function TBlockSerial.GetCTS: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + Result := (FModemWord and TIOCM_CTS) > 0; +{$ELSE} + Result := (FModemWord and SERIAL_STATUS_CTS) <> 0; +{$ENDIF} +{$ELSE} + Result := (FModemWord and MS_CTS_ON) > 0; +{$ENDIF} +end; + +procedure TBlockSerial.SetRTSF(Value: Boolean); +begin +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + ModemStatus; + if Value then + FModemWord := FModemWord or TIOCM_RTS + else + FModemWord := FModemWord and not TIOCM_RTS; + {$IFNDEF FPC} + ioctl(FHandle, TIOCMSET, @FModemWord); + {$ELSE} + fpioctl(FHandle, TIOCMSET, @FModemWord); + {$ENDIF} +{$ELSE} + if Value then + SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) or SERIAL_STATUS_RTS) + else + SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) and not(SERIAL_STATUS_RTS)); +{$ENDIF} +{$ELSE} + if Value then + EscapeCommFunction(FHandle, SETRTS) + else + EscapeCommFunction(FHandle, CLRRTS); +{$ENDIF} +end; + +function TBlockSerial.GetCarrier: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + Result := (FModemWord and TIOCM_CAR) > 0; +{$ELSE} + Result := (FModemWord and SERIAL_STATUS_DCD) <> 0; +{$ENDIF} +{$ELSE} + Result := (FModemWord and MS_RLSD_ON) > 0; +{$ENDIF} +end; + +function TBlockSerial.GetRing: Boolean; +begin + ModemStatus; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + Result := (FModemWord and TIOCM_RNG) > 0; +{$ELSE} + Result := (FModemWord and SERIAL_STATUS_RI) <> 0; +{$ENDIF} +{$ELSE} + Result := (FModemWord and MS_RING_ON) > 0; +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean; +var + ex: DWord; + y: Integer; + Overlapped: TOverlapped; +begin + FillChar(Overlapped, Sizeof(Overlapped), 0); + Overlapped.hEvent := CreateEvent(nil, True, False, nil); + try + SetCommMask(FHandle, Event); + SetSynaError(sOK); + if (Event = EV_RXCHAR) and (Waitingdata > 0) then + Result := True + else + begin + y := 0; + ex := 0; + if not WaitCommEvent(FHandle, ex, @Overlapped) then + y := GetLastError; + if y = ERROR_IO_PENDING then + begin + //timedout + WaitForSingleObject(Overlapped.hEvent, Timeout); + SetCommMask(FHandle, 0); + GetOverlappedResult(FHandle, Overlapped, DWord(y), True); + end; + Result := (ex and Event) = Event; + end; + finally + SetCommMask(FHandle, 0); + CloseHandle(Overlapped.hEvent); + end; +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +function TBlockSerial.CanRead(Timeout: integer): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + {$IFNDEF FPC} + FD_ZERO(FDSet); + FD_SET(FHandle, FDSet); + x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); + {$ELSE} + fpFD_ZERO(FDSet); + fpFD_SET(FHandle, FDSet); + x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal); + {$ENDIF} + SerialCheck(x); + if FLastError <> sOK then + x := 0; + Result := x > 0; + ExceptCheck; + if Result then + DoStatus(HR_CanRead, ''); +end; +{$ELSE} +function TBlockSerial.CanRead(Timeout: integer): boolean; +var + Count: LongWord; +begin + Result := WaitingData > 0; + if not Result then + begin + if Timeout <> 0 then + begin + if Timeout = -1 then + Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_RECEIVE, INFINITE, Count) = ERROR_SUCCESS + else + Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_RECEIVE, Timeout, Count) = ERROR_SUCCESS; + end; + end; + if Result then + DoStatus(HR_CanRead, ''); +end; +{$ENDIF} +{$ELSE} +function TBlockSerial.CanRead(Timeout: integer): boolean; +begin + Result := WaitingData > 0; + if not Result then + Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0); + //check WaitingData again due some broken virtual ports + if Result then + DoStatus(HR_CanRead, ''); +end; +{$ENDIF} + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +function TBlockSerial.CanWrite(Timeout: integer): boolean; +var + FDSet: TFDSet; + TimeVal: PTimeVal; + TimeV: TTimeVal; + x: Integer; +begin + TimeV.tv_usec := (Timeout mod 1000) * 1000; + TimeV.tv_sec := Timeout div 1000; + TimeVal := @TimeV; + if Timeout = -1 then + TimeVal := nil; + {$IFNDEF FPC} + FD_ZERO(FDSet); + FD_SET(FHandle, FDSet); + x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); + {$ELSE} + fpFD_ZERO(FDSet); + fpFD_SET(FHandle, FDSet); + x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal); + {$ENDIF} + SerialCheck(x); + if FLastError <> sOK then + x := 0; + Result := x > 0; + ExceptCheck; + if Result then + DoStatus(HR_CanWrite, ''); +end; +{$ELSE} +function TBlockSerial.CanWrite(Timeout: integer): boolean; +var + Count: LongWord; +begin + Result := SendingData < FSendBuffer; + if not Result then + begin + if Timeout <> 0 then + begin + if Timeout = -1 then + Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_TRANSMIT, INFINITE, Count) = ERROR_SUCCESS + else + Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_TRANSMIT, Timeout, Count) = ERROR_SUCCESS; + end; + end; + if Result then + DoStatus(HR_CanWrite, ''); +end; +{$ENDIF} +{$ELSE} +function TBlockSerial.CanWrite(Timeout: integer): boolean; +var + t: LongWord; +begin + Result := SendingData = 0; + if not Result then + Result := CanEvent(EV_TXEMPTY, Timeout); + {$IFDEF WIN32} + if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then + begin + t := GetTick; + while not ReadTxEmpty(FPortAddr) do + begin + if TickDelta(t, GetTick) > 255 then + Break; + Sleep(0); + end; + end; + {$ENDIF} + if Result then + DoStatus(HR_CanWrite, ''); +end; +{$ENDIF} + +function TBlockSerial.CanReadEx(Timeout: integer): boolean; +begin + if Fbuffer <> '' then + Result := True + else + Result := CanRead(Timeout); +end; + +procedure TBlockSerial.EnableRTSToggle(Value: boolean); +begin + SetSynaError(sOK); +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + FRTSToggle := Value; + if Value then + RTS:=False; +{$ELSE} + FRTSToggle := Value; + if Value then + RTS:=False; +{$ENDIF} +{$ELSE} + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + GetCommState; + if value then + dcb.Flags := dcb.Flags or dcb_RtsControlToggle + else + dcb.flags := dcb.flags and (not dcb_RtsControlToggle); + SetCommState; + end + else + begin + FRTSToggle := Value; + if Value then + RTS:=False; + end; +{$ENDIF} +end; + +procedure TBlockSerial.Flush; +begin +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + SerialCheck(tcdrain(FHandle)); +{$ELSE} + SetSynaError(sOK); + while SendingData > 0 do + begin + Sleep(0); + end; +{$ENDIF} +{$ELSE} + SetSynaError(sOK); + if not Flushfilebuffers(FHandle) then + SerialCheck(sErr); +{$ENDIF} + ExceptCheck; +end; + +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +procedure TBlockSerial.Purge; +begin + {$IFNDEF FPC} + SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH)); + {$ELSE} + {$IFDEF DARWIN} + SerialCheck(fpioctl(FHandle, TCIOflush, Pointer(PtrInt(TCIOFLUSH)))); + {$ELSE} + SerialCheck(fpioctl(FHandle, {$IFDEF FreeBSD}TCIOFLUSH{$ELSE}TCFLSH{$ENDIF}, Pointer(PtrInt(TCIOFLUSH)))); + {$ENDIF} + {$ENDIF} + FBuffer := ''; + ExceptCheck; +end; +{$ELSE} +procedure TBlockSerial.Purge; +begin + SetSynaError(sOK); + if SerialDeviceFlush(FSerialDevice, SERIAL_FLUSH_RECEIVE or SERIAL_FLUSH_TRANSMIT) <> ERROR_SUCCESS then + begin + SerialCheck(sErr); + end; + FBuffer := ''; + ExceptCheck; +end; +{$ENDIF} +{$ELSE} +procedure TBlockSerial.Purge; +var + x: integer; +begin + SetSynaError(sOK); + x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR; + if not PurgeComm(FHandle, x) then + SerialCheck(sErr); + FBuffer := ''; + ExceptCheck; +end; +{$ENDIF} + +function TBlockSerial.ModemStatus: integer; +begin + Result := 0; +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + {$IFNDEF FPC} + SerialCheck(ioctl(FHandle, TIOCMGET, @Result)); + {$ELSE} + SerialCheck(fpioctl(FHandle, TIOCMGET, @Result)); + {$ENDIF} +{$ELSE} + SetSynaError(sOK); + Result:=SerialDeviceStatus(FSerialDevice); +{$ENDIF} +{$ELSE} + SetSynaError(sOK); + if not GetCommModemStatus(FHandle, dword(Result)) then + SerialCheck(sErr); +{$ENDIF} + ExceptCheck; + FModemWord := Result; +end; + +procedure TBlockSerial.SetBreak(Duration: integer); +begin +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} + SerialCheck(tcsendbreak(FHandle, Duration)); +{$ELSE} + //To Do //Ultibo //SerialDeviceSetBreak/ClearBreak to be implemented +{$ENDIF} +{$ELSE} + SetCommBreak(FHandle); + Sleep(Duration); + SetSynaError(sOK); + if not ClearCommBreak(FHandle) then + SerialCheck(sErr); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure TBlockSerial.DecodeCommError(Error: DWord); +begin + if (Error and DWord(CE_FRAME)) > 1 then + FLastError := ErrFrame; + if (Error and DWord(CE_OVERRUN)) > 1 then + FLastError := ErrOverrun; + if (Error and DWord(CE_RXOVER)) > 1 then + FLastError := ErrRxOver; + if (Error and DWord(CE_RXPARITY)) > 1 then + FLastError := ErrRxParity; + if (Error and DWord(CE_TXFULL)) > 1 then + FLastError := ErrTxFull; +end; +{$ENDIF} + +//HGJ +function TBlockSerial.PreTestFailing: Boolean; +begin + if not FInstanceActive then + begin + RaiseSynaError(ErrPortNotOpen); + result:= true; + Exit; + end; + Result := not TestCtrlLine; + if result then + RaiseSynaError(ErrNoDeviceAnswer) +end; + +function TBlockSerial.TestCtrlLine: Boolean; +begin + result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS); +end; + +function TBlockSerial.ATCommand(value: AnsiString): AnsiString; +var + s: AnsiString; + ConvSave: Boolean; +begin + result := ''; + FAtResult := False; + ConvSave := FConvertLineEnd; + try + FConvertLineEnd := True; + SendString(value + #$0D); + repeat + s := RecvString(FAtTimeout); + if s <> Value then + result := result + s + CRLF; + if s = 'OK' then + begin + FAtResult := True; + break; + end; + if s = 'ERROR' then + break; + until FLastError <> sOK; + finally + FConvertLineEnd := Convsave; + end; +end; + + +function TBlockSerial.ATConnect(value: AnsiString): AnsiString; +var + s: AnsiString; + ConvSave: Boolean; +begin + result := ''; + FAtResult := False; + ConvSave := FConvertLineEnd; + try + FConvertLineEnd := True; + SendString(value + #$0D); + repeat + s := RecvString(90 * FAtTimeout); + if s <> Value then + result := result + s + CRLF; + if s = 'NO CARRIER' then + break; + if s = 'ERROR' then + break; + if s = 'BUSY' then + break; + if s = 'NO DIALTONE' then + break; + if Pos('CONNECT', s) = 1 then + begin + FAtResult := True; + break; + end; + until FLastError <> sOK; + finally + FConvertLineEnd := Convsave; + end; +end; + +function TBlockSerial.SerialCheck(SerialResult: integer): integer; +begin + if SerialResult = integer(INVALID_HANDLE_VALUE) then +{$IFDEF MSWINDOWS} + result := GetLastError +{$ELSE} + {$IFDEF ULTIBO} + result := GetLastError + {$ELSE} + {$IFNDEF FPC} + result := GetLastError + {$ELSE} + result := fpGetErrno + {$ENDIF} + {$ENDIF} +{$ENDIF} + else + result := sOK; + FLastError := result; + FLastErrorDesc := GetErrorDesc(FLastError); +end; + +procedure TBlockSerial.ExceptCheck; +var + e: ESynaSerError; + s: string; +begin + if FRaiseExcept and (FLastError <> sOK) then + begin + s := GetErrorDesc(FLastError); + e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]); + e.ErrorCode := FLastError; + e.ErrorMessage := s; + raise e; + end; +end; + +procedure TBlockSerial.SetSynaError(ErrNumber: integer); +begin + FLastError := ErrNumber; + FLastErrorDesc := GetErrorDesc(FLastError); +end; + +procedure TBlockSerial.RaiseSynaError(ErrNumber: integer); +begin + SetSynaError(ErrNumber); + ExceptCheck; +end; + +procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string); +begin + if assigned(OnStatus) then + OnStatus(Self, Reason, Value); +end; + +{======================================================================} + +class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string; +begin + Result:= ''; + case ErrorCode of + sOK: Result := 'OK'; + ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ} + ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ} + ErrWrongParameter: Result := 'Wrong parameter at call'; {HGJ} + ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ} + ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ} + ErrMaxBuffer: Result := 'Maximal buffer length exceeded'; + ErrTimeout: Result := 'Timeout during operation'; + ErrNotRead: Result := 'Reading of data failed'; + ErrFrame: Result := 'Receive framing error'; + ErrOverrun: Result := 'Receive Overrun Error'; + ErrRxOver: Result := 'Receive Queue overflow'; + ErrRxParity: Result := 'Receive Parity Error'; + ErrTxFull: Result := 'Tranceive Queue is full'; + end; + if Result = '' then + begin + Result := SysErrorMessage(ErrorCode); + end; +end; + + +{---------- cpom Comport Ownership Manager Routines ------------- + by Hans-Georg Joepgen of Stuttgart, Germany. + Copyright (c) 2002, by Hans-Georg Joepgen + + Stefan Krauss of Stuttgart, Germany, contributed literature and Internet + research results, invaluable advice and excellent answers to the Comport + Ownership Manager. +} + +{$IFDEF UNIX} + +function TBlockSerial.LockfileName: String; +var + s: string; +begin + s := SeparateRight(FDevice, '/dev/'); + result := LockfileDirectory + '/LCK..' + s; +end; + +procedure TBlockSerial.CreateLockfile(PidNr: integer); +var + f: TextFile; + s: string; +begin + // Create content for file + s := IntToStr(PidNr); + while length(s) < 10 do + s := ' ' + s; + // Create file + try + AssignFile(f, LockfileName); + try + Rewrite(f); + writeln(f, s); + finally + CloseFile(f); + end; + // Allow all users to enjoy the benefits of cpom + s := 'chmod a+rw ' + LockfileName; + {$IFNDEF FPC} + FileSetReadOnly( LockfileName, False ) ; + // Libc.system(pchar(s)); + {$ELSE} + fpSystem(s); + {$ENDIF} + except + // not raise exception, if you not have write permission for lock. + on Exception do + ; + end; +end; + +function TBlockSerial.ReadLockfile: integer; +{Returns PID from Lockfile. Lockfile must exist.} +var + f: TextFile; + s: string; +begin + AssignFile(f, LockfileName); + Reset(f); + try + readln(f, s); + finally + CloseFile(f); + end; + Result := StrToIntDef(s, -1) +end; + +function TBlockSerial.cpomComportAccessible: boolean; +var + MyPid: integer; + Filename: string; +begin + Filename := LockfileName; + {$IFNDEF FPC} + MyPid := Libc.getpid; + {$ELSE} + MyPid := fpGetPid; + {$ENDIF} + // Make sure, the Lock Files Directory exists. We need it. + if not DirectoryExists(LockfileDirectory) then + CreateDir(LockfileDirectory); + // Check the Lockfile + if not FileExists (Filename) then + begin // comport is not locked. Lock it for us. + CreateLockfile(MyPid); + result := true; + exit; // done. + end; + // Is port owned by orphan? Then it's time for error recovery. + //FPC forgot to add getsid.. :-( + {$IFNDEF FPC} + if Libc.getsid(ReadLockfile) = -1 then + begin // Lockfile was left from former desaster + DeleteFile(Filename); // error recovery + CreateLockfile(MyPid); + result := true; + exit; + end; + {$ENDIF} + result := false // Sorry, port is owned by living PID and locked +end; + +procedure TBlockSerial.cpomReleaseComport; +begin + DeleteFile(LockfileName); +end; + +{$ENDIF} +{----------------------------------------------------------------} + +{$IFDEF MSWINDOWS} +function GetSerialPortNames: string; +var + reg: TRegistry; + l, v: TStringList; + n: integer; +begin + l := TStringList.Create; + v := TStringList.Create; + reg := TRegistry.Create; + try +{$IFNDEF VER100} +{$IFNDEF VER120} + reg.Access := KEY_READ; +{$ENDIF} +{$ENDIF} + reg.RootKey := HKEY_LOCAL_MACHINE; + reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false); + reg.GetValueNames(l); + for n := 0 to l.Count - 1 do + v.Add(PChar(reg.ReadString(l[n]))); + Result := v.CommaText; + finally + reg.Free; + l.Free; + v.Free; + end; +end; +{$ENDIF} +{$IFNDEF MSWINDOWS} +{$IFNDEF ULTIBO} +function GetSerialPortNames: string; +var + sr : TSearchRec; +begin + Result := ''; + if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then + repeat + if (sr.Attr and $FFFFFFFF) = Sr.Attr then + begin + if Result <> '' then + Result := Result + ','; + Result := Result + '/dev/' + sr.Name; + end; + until FindNext(sr) <> 0; + FindClose(sr); + if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin + repeat + if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin + if Result <> '' then Result := Result + ','; + Result := Result + '/dev/' + sr.Name; + end; + until FindNext(sr) <> 0; + end; + FindClose(sr); + if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin + repeat + if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin + if Result <> '' then Result := Result + ','; + Result := Result + '/dev/' + sr.Name; + end; + until FindNext(sr) <> 0; + end; + FindClose(sr); +end; +{$ELSE} +type + PSerialCallbackData = ^TSerialCallbackData; + TSerialCallbackData = record + Count: Integer; + Devices: String; + end; + +function SerialDeviceCallback(Serial:PSerialDevice;Data:Pointer):LongWord; +var + SerialCallbackData: PSerialCallbackData; +begin + Result := ERROR_INVALID_PARAMETER; + + if Serial = nil then Exit; + if Data = nil then Exit; + + //Get data + SerialCallbackData := PSerialCallbackData(Data); + + //Increment count + Inc(SerialCallbackData.Count); + + //Add comma + if SerialCallbackData.Devices <> '' then + SerialCallbackData.Devices := SerialCallbackData.Devices + ','; + + //Add device name + SerialCallbackData.Devices := SerialCallbackData.Devices + DeviceGetName(@Serial.Device); + + Result:=ERROR_SUCCESS; +end; + +function GetSerialPortNames: string; +var + SerialCallbackData: TSerialCallbackData; +begin + //Setup callback + SerialCallbackData.Count := 0; + SerialCallbackData.Devices := ''; + + //Perform callback + SerialDeviceEnumerate(SerialDeviceCallback, @SerialCallbackData); + + //Return names + Result := SerialCallbackData.Devices; +end; +{$ENDIF} +{$ENDIF} + +end. diff --git a/synautil.pas b/synautil.pas new file mode 100644 index 0000000..ee7ceb7 --- /dev/null +++ b/synautil.pas @@ -0,0 +1,2161 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.015.007 | +|==============================================================================| +| Content: support procedures and functions | +|==============================================================================| +| Copyright (c)1999-2017, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c) 1999-2017. | +| Portions created by Hernan Sanchez are Copyright (c) 2000. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Hernan Sanchez (hernan.sanchez@iname.com) | +| Tomas Hajny (OS2 support) | +| Radek Cervinka (POSIX support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Support procedures and functions)} + +{$I jedi.inc} // load common compiler defines + +{$Q-} +{$R-} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} + {$WARN SUSPICIOUS_TYPECAST OFF} +{$ENDIF} + +unit synautil; + +interface + +uses +{$IFDEF MSWINDOWS} + Windows, +{$ELSE MSWINDOWS} + {$IFDEF ULTIBO} + Ultibo, + {$ELSE} + {$IFDEF FPC} + {$IFDEF OS2} + Dos, TZUtil, + {$ELSE OS2} + UnixUtil, Unix, BaseUnix, + {$ENDIF OS2} + {$ELSE FPC} + {$IFDEF POSIX} + Posix.Base, Posix.Time, Posix.SysTypes, Posix.SysTime, Posix.Stdio, + Posix.Unistd, + {$ELSE} + Libc, + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} +{$IFDEF CIL} + System.IO, +{$ENDIF} + SysUtils, Classes, SynaFpc, synabyte; + +{$IFDEF VER100} +type + int64 = integer; +{$ENDIF} +{$IFDEF POSIX} +type + TTimeVal = Posix.SysTime.timeval; + Ttimezone = record + tz_minuteswest: Integer ; // minutes west of Greenwich + tz_dsttime: integer ; // type of DST correction + end; + + PTimeZone = ^Ttimezone; +{$ENDIF} + + +{:Return your timezone bias from UTC time in minutes.} +function TimeZoneBias: integer; + +{:Return your timezone bias from UTC time in string representation like "+0200".} +function TimeZone: string; + +{:Returns current time in format defined in RFC-822. Useful for SMTP messages, + but other protocols use this time format as well. Results contains the timezone + specification. Four digit year is used to break any Y2K concerns. (Example + 'Fri, 15 Oct 1999 21:14:56 +0200')} +function Rfc822DateTime(t: TDateTime): string; + +{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"} +function CDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in format 'yymmdd hhnnss'} +function SimpleDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in ANSI C compilers in format + "ddd mmm d hh:nn:ss yyyy" } +function AnsiCDateTime(t: TDateTime): string; + +{:Decode three-letter string with name of month to their month number. If string + not match any month name, then is returned 0. For parsing are used predefined + names for English, French and German and names from system locale too.} +function GetMonthNumber(Value: String): integer; + +{:Return decoded time from given string. Time must be witch separator ':'. You + can use "hh:mm" or "hh:mm:ss".} +function GetTimeFromStr(Value: string): TDateTime; + +{:Decode string representation of TimeZone (CEST, GMT, +0200, -0800, etc.) + to timezone offset.} +function DecodeTimeZone(const Value: string; var Zone: integer): Boolean; + +{:Decode string in format "m-d-y" to TDateTime type.} +function GetDateMDYFromStr(Value: string): TDateTime; + +{:Decode various string representations of date and time to Tdatetime type. + This function do all timezone corrections too! This function can decode lot of + formats like: + @longcode(# + ddd, d mmm yyyy hh:mm:ss + ddd, d mmm yy hh:mm:ss + ddd, mmm d yyyy hh:mm:ss + ddd mmm dd hh:mm:ss yyyy #) + +and more with lot of modifications, include: +@longcode(# +Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format +#) +Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.) +or numeric representation (like +0200). By convention defined in RFC timezone + +0000 is GMT and -0000 is current your system timezone.} +function DecodeRfcDateTime(Value: string): TDateTime; + +{:Return current system date and time in UTC timezone.} +function GetUTTime: TDateTime; + +{:Set Newdt as current system date and time in UTC timezone. This function work + only if you have administrator rights!} +function SetUTTime(Newdt: TDateTime): Boolean; + +{:Return current value of system timer with precizion 1 millisecond. Good for + measure time difference.} +function GetTick: LongWord; + +{:Return difference between two timestamps. It working fine only for differences + smaller then maxint. (difference must be smaller then 24 days.)} +function TickDelta(TickOld, TickNew: LongWord): LongWord; + +{:Return two characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeInt(Value: Word): string; + +{:Decodes two characters located at "Index" offset position of the "Value" + string to Word values.} +function DecodeInt(const Value: string; Index: integer): Word; + +{:Return four characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeLongInt(Value: LongInt): string; + +{:Decodes four characters located at "Index" offset position of the "Value" + string to LongInt values.} +function DecodeLongInt(const Value: string; Index: integer): LongInt; + +{:Dump binary buffer stored in a string to a result string.} +function DumpStr(const Buffer: string): string; + +{:Dump binary buffer stored in a string to a result string. All bytes with code + of character is written as character, not as hexadecimal value.} +function DumpExStr(const Buffer: string): string; + +{:Dump binary buffer stored in a string to a file with DumpFile filename.} +procedure Dump(const Buffer: string; const DumpFile: string); + +{:Dump binary buffer stored in a string to a file with DumpFile filename. All + bytes with code of character is written as character, not as hexadecimal value.} +procedure DumpEx(const Buffer: string; const DumpFile: string); + +{:Like TrimLeft, but remove only spaces, not control characters!} +function TrimSPLeft(const S: string): string; + +{:Like TrimRight, but remove only spaces, not control characters!} +function TrimSPRight(const S: string): string; + +{:Like Trim, but remove only spaces, not control characters!} +function TrimSP(const S: string): string; + +{:Returns a portion of the "Value" string located to the left of the "Delimiter" + string. If a delimiter is not found, results is original string.} +function SeparateLeft(const Value, Delimiter: string): string; + +{:Returns the portion of the "Value" string located to the right of the + "Delimiter" string. If a delimiter is not found, results is original string.} +function SeparateRight(const Value, Delimiter: string): string; + +{:Returns parameter value from string in format: + parameter1="value1"; parameter2=value2} +function GetParameter(const Value, Parameter: string): string; + +{:parse value string with elements differed by Delimiter into stringlist.} +procedure ParseParametersEx(Value: string; const Delimiter: string; const Parameters: TStrings); + +{:parse value string with elements differed by ';' into stringlist.} +procedure ParseParameters(const Value: string; const Parameters: TStrings); + +{:Index of string in stringlist with same beginning as Value is returned.} +function IndexByBegin(Value: string; const List: TStrings): integer; + +{:Returns only the e-mail portion of an address from the full address format. + i.e. returns 'nobody@@somewhere.com' from '"someone" '} +function GetEmailAddr(const Value: string): string; + +{:Returns only the description part from a full address format. i.e. returns + 'someone' from '"someone" '} +function GetEmailDesc(Value: string): string; + +{:Returns a string with hexadecimal digits representing the corresponding values + of the bytes found in "Value" string.} +function StrToHex(const Value: string): string; + +{:Returns a string of binary "Digits" representing "Value".} +function IntToBin(Value: Integer; Digits: Byte): string; + +{:Returns an integer equivalent of the binary string in "Value". + (i.e. ('10001010') returns 138)} +function BinToInt(const Value: string): Integer; + +{:Parses a URL to its various components.} +function ParseURL(const URL: string; var Prot, User, Pass, Host, Port, Path, + Para: string): string; + +{:Replaces all "Search" string values found within "Value" string, with the + "Replace" string value.} +function ReplaceString(Value: string; const Search, Replace: string): string; + +{:It is like RPos, but search is from specified possition.} +function RPosEx(const Sub, Value: string; From: integer): Integer; + +{:It is like POS function, but from right side of Value string.} +function RPos(const Sub, Value: String): Integer; + +{:Like @link(fetch), but working with binary strings, not with text.} +function FetchBin(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string.} +function Fetch(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string. This function ignore delimitesr inside + quotations.} +function FetchEx(var Value: string; const Delimiter, Quotation: string): string; + +{:If string is binary string (contains non-printable characters), then is + returned true.} +function IsBinaryString(const Value: string): Boolean; + +{:return position of string terminator in string. If terminator found, then is + returned in terminator parameter. + Possible line terminators are: CRLF, LFCR, CR, LF} +function PosCRLF(const Value: string; var Terminator: string): integer; + +{:Delete empty strings from end of stringlist.} +Procedure StringsTrim(const value: TStrings); + +{:Like Pos function, buf from given string possition.} +function PosFrom(const SubStr, Value: String; From: integer): integer; + +{$IFNDEF CIL} +{:Increase pointer by value.} +function IncPoint(const p: pbyte; Value: integer): pointer; +{$ENDIF} + +{:Get string between PairBegin and PairEnd. This function respect nesting. + For example: + @longcode(# + Value is: 'Hi! (hello(yes!))' + pairbegin is: '(' + pairend is: ')' + In this case result is: 'hello(yes!)'#)} +function GetBetween(const PairBegin, PairEnd, Value: string): string; + +{:Return count of Chr in Value string.} +function CountOfChar(const Value: string; Chr: char): integer; + +{:Remove quotation from Value string. If Value is not quoted, then return same + string without any modification. } +function UnquoteStr(const Value: string; Quote: Char): string; + +{:Quote Value string. If Value contains some Quote chars, then it is doubled.} +function QuoteStr(const Value: string; Quote: Char): string; + +{:Convert lines in stringlist from 'name: value' form to 'name=value' form.} +procedure HeadersToList(const Value: TStrings); + +{:Convert lines in stringlist from 'name=value' form to 'name: value' form.} +procedure ListToHeaders(const Value: TStrings); + +{:swap bytes in integer.} +function SwapBytes(Value: integer): integer; + +{:read string with requested length form stream.} +function ReadStrFromStream(const Stream: TStream; len: integer): string; + +{:write string to stream.} +procedure WriteStrToStream(const Stream: TStream; const Value: string); {$IFDEF UNICODE} overload;{$ENDIF} + +{$IFDEF UNICODE} +procedure WriteStrToStream(const Stream: TStream; const Value: TSynaBytes); overload; +{$ENDIF} + +{:Return filename of new temporary file in Dir (if empty, then default temporary + directory is used) and with optional filename prefix.} +function GetTempFile(const Dir, prefix: TFileName): TFileName; + +{:Return padded string. If length is greater, string is truncated. If length is + smaller, string is padded by Pad character.} +function PadString(const Value: string; len: integer; Pad: char): string; + +{:XOR each byte in the strings} +function XorString(const Indata1: string; Indata2: string): string; + +{:Read header from "Value" stringlist beginning at "Index" position. If header + is Splitted into multiple lines, then this procedure de-split it into one line.} +function NormalizeHeader(Value: TStrings; var Index: Integer): string; + +{pf} +{:Search for one of line terminators CR, LF or NUL. Return position of the + line beginning and length of text.} +procedure SearchForLineBreak(var APtr: PChar; AEtx: PChar; out ABol: PChar; out ALength: integer); +{:Skip both line terminators CR LF (if any). Move APtr position forward.} +procedure SkipLineBreak(var APtr: PChar; AEtx: PChar); +{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.} +procedure SkipNullLines(var APtr: PChar; AEtx: PChar); +{:Copy all lines from a buffer starting at APtr to ALines until empty line + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilNullLine(var APtr: PChar; AEtx: PChar; ALines: TStrings); +{:Copy all lines from a buffer starting at APtr to ALines until ABoundary + or end of the buffer is reached. Move APtr position forward).} +procedure CopyLinesFromStreamUntilBoundary(var APtr: PChar; AEtx: PChar; ALines: TStrings; const ABoundary: string); +{:Search ABoundary in a buffer starting at APtr. + Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).} +function SearchForBoundary(var APtr: PChar; AEtx: PChar; const ABoundary: string): PChar; +{:Compare a text at position ABOL with ABoundary and return position behind the + match (including a trailing CRLF if any).} +function MatchBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar; +{:Compare a text at position ABOL with ABoundary + the last boundary suffix + and return position behind the match (including a trailing CRLF if any).} +function MatchLastBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar; +{:Copy data from a buffer starting at position APtr and delimited by AEtx + position into string. } +function BuildStringFromBuffer(AStx, AEtx: PChar): string; +{/pf} + +function CompareString(const Str1, Str2: String; const CaseSensitive: Boolean = false): Boolean; + +var + {:can be used for your own months strings for @link(getmonthnumber)} + CustomMonthNames: array[1..12] of string; + +implementation + +{==============================================================================} + +const + MyDayNames: array[1..7] of string = + ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); +var + MyMonthNames: array[0..6, 1..12] of String = + ( + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French + 'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'), + ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2 + 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', //German#2 + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen', //Czech + 'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro') + ); + + +{==============================================================================} + +function TimeZoneBias: integer; +{$IF NOT(DEFINED(MSWINDOWS)) and NOT(DEFINED(ULTIBO))} +{$IFNDEF FPC} +var +{$IFDEF POSIX} + t: Posix.SysTypes.time_t; + UT: Posix.time.tm; +{$ELSE} + t: TTime_T; + UT: TUnixTime; +{$ENDIF} +begin + {$IFDEF POSIX} + __time(T); + localtime_r(T, UT); + Result := UT.tm_gmtoff div 60; + {$ELSE} + __time(@T); + localtime_r(@T, UT); + Result := ut.__tm_gmtoff div 60; + {$ENDIF} +{$ELSE} +begin + Result := TZSeconds div 60; +{$ENDIF} +{$ELSE} +var + zoneinfo: TTimeZoneInformation; + bias: Integer; +begin + case GetTimeZoneInformation(Zoneinfo) of + 2: + bias := zoneinfo.Bias + zoneinfo.DaylightBias; + 1: + bias := zoneinfo.Bias + zoneinfo.StandardBias; + else + bias := zoneinfo.Bias; + end; + Result := bias * (-1); +{$ENDIF} +end; + +{==============================================================================} + +function TimeZone: string; +var + bias: Integer; + h, m: Integer; +begin + bias := TimeZoneBias; + if bias >= 0 then + Result := '+' + else + Result := '-'; + bias := Abs(bias); + h := bias div 60; + m := bias mod 60; + Result := Result + Format('%.2d%.2d', [h, m]); +end; + +{==============================================================================} + +function Rfc822DateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, + MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]); +end; + +{==============================================================================} + +function CDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay, + FormatDateTime('hh":"nn":"ss', t)]); +end; + +{==============================================================================} + +function SimpleDateTime(t: TDateTime): string; +begin + Result := FormatDateTime('yymmdd hhnnss', t); +end; + +{==============================================================================} + +function AnsiCDateTime(t: TDateTime): string; +var + wYear, wMonth, wDay: word; +begin + DecodeDate(t, wYear, wMonth, wDay); + Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth], + wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]); +end; + +{==============================================================================} + +function DecodeTimeZone(const Value: string; var Zone: integer): Boolean; +var + x: integer; + zh, zm: integer; + s: string; +begin + Result := false; + s := Value; + if (Pos('+', s) = 1) or (Pos('-',s) = 1) then + begin + if s = '-0000' then + Zone := TimeZoneBias + else + if Length(s) > 4 then + begin + zh := StrToIntDef(s[2] + s[3], 0); + zm := StrToIntDef(s[4] + s[5], 0); + zone := zh * 60 + zm; + if s[1] = '-' then + zone := zone * (-1); + end; + Result := True; + end + else + begin + x := 32767; + if s = 'NZDT' then x := 13; + if s = 'IDLE' then x := 12; + if s = 'NZST' then x := 12; + if s = 'NZT' then x := 12; + if s = 'EADT' then x := 11; + if s = 'GST' then x := 10; + if s = 'JST' then x := 9; + if s = 'CCT' then x := 8; + if s = 'WADT' then x := 8; + if s = 'WAST' then x := 7; + if s = 'ZP6' then x := 6; + if s = 'ZP5' then x := 5; + if s = 'ZP4' then x := 4; + if s = 'BT' then x := 3; + if s = 'EET' then x := 2; + if s = 'MEST' then x := 2; + if s = 'MESZ' then x := 2; + if s = 'SST' then x := 2; + if s = 'FST' then x := 2; + if s = 'CEST' then x := 2; + if s = 'CET' then x := 1; + if s = 'FWT' then x := 1; + if s = 'MET' then x := 1; + if s = 'MEWT' then x := 1; + if s = 'SWT' then x := 1; + if s = 'UT' then x := 0; + if s = 'UTC' then x := 0; + if s = 'GMT' then x := 0; + if s = 'WET' then x := 0; + if s = 'WAT' then x := -1; + if s = 'BST' then x := -1; + if s = 'AT' then x := -2; + if s = 'ADT' then x := -3; + if s = 'AST' then x := -4; + if s = 'EDT' then x := -4; + if s = 'EST' then x := -5; + if s = 'CDT' then x := -5; + if s = 'CST' then x := -6; + if s = 'MDT' then x := -6; + if s = 'MST' then x := -7; + if s = 'PDT' then x := -7; + if s = 'PST' then x := -8; + if s = 'YDT' then x := -8; + if s = 'YST' then x := -9; + if s = 'HDT' then x := -9; + if s = 'AHST' then x := -10; + if s = 'CAT' then x := -10; + if s = 'HST' then x := -10; + if s = 'EAST' then x := -10; + if s = 'NT' then x := -11; + if s = 'IDLW' then x := -12; + if x <> 32767 then + begin + zone := x * 60; + Result := True; + end; + end; +end; + +{==============================================================================} + +function GetMonthNumber(Value: String): integer; +var + n: integer; + function TestMonth(const Value: String; Index: Integer): Boolean; + var + n: integer; + begin + Result := False; + for n := 0 to 6 do + if Value = AnsiUppercase(MyMonthNames[n, Index]) then + begin + Result := True; + Break; + end; + end; +begin + Result := 0; + Value := AnsiUppercase(Value); + for n := 1 to 12 do + if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then + begin + Result := n; + Break; + end; +end; + +{==============================================================================} + +function GetTimeFromStr(Value: string): TDateTime; +var + x: integer; +begin + x := rpos(':', Value); + if (x > 0) and ((Length(Value) - x) > 2) then + Value := Copy(Value, 1, x + 2); + Value := ReplaceString(Value, ':', {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}TimeSeparator); + Result := -1; + try + Result := StrToTime(Value); + except + on Exception do ; + end; +end; + +{==============================================================================} + +function GetDateMDYFromStr(Value: string): TDateTime; +var + wYear, wMonth, wDay: word; + s: string; +begin + Result := 0; + s := Fetch(Value, '-'); + wMonth := StrToIntDef(s, 12); + s := Fetch(Value, '-'); + wDay := StrToIntDef(s, 30); + wYear := StrToIntDef(Value, 1899); + if wYear < 1000 then + if (wYear > 99) then + wYear := wYear + 1900 + else + if wYear > 50 then + wYear := wYear + 1900 + else + wYear := wYear + 2000; + try + Result := EncodeDate(wYear, wMonth, wDay); + except + on Exception do ; + end; +end; + +{==============================================================================} + +function DecodeRfcDateTime(Value: string): TDateTime; +var + day, month, year: Word; + zone: integer; + x, y: integer; + s: string; + t: TDateTime; +begin +// ddd, d mmm yyyy hh:mm:ss +// ddd, d mmm yy hh:mm:ss +// ddd, mmm d yyyy hh:mm:ss +// ddd mmm dd hh:mm:ss yyyy +// Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +// Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +// Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format + + Result := 0; + if Value = '' then + Exit; + day := 0; + month := 0; + year := 0; + zone := 0; + Value := ReplaceString(Value, ' -', ' #'); + Value := ReplaceString(Value, '-', ' '); + Value := ReplaceString(Value, ' #', ' -'); + while Value <> '' do + begin + s := Fetch(Value, ' '); + s := uppercase(s); + // timezone + if DecodetimeZone(s, x) then + begin + zone := x; + continue; + end; + x := StrToIntDef(s, 0); + // day or year + if x > 0 then + if (x < 32) and (day = 0) then + begin + day := x; + continue; + end + else + begin + if (year = 0) and ((month > 0) or (x > 12)) then + begin + year := x; + if year < 32 then + year := year + 2000; + if year < 1000 then + year := year + 1900; + continue; + end; + end; + // time + if rpos(':', s) > Pos(':', s) then + begin + t := GetTimeFromStr(s); + if t <> -1 then + Result := t; + continue; + end; + //timezone daylight saving time + if s = 'DST' then + begin + zone := zone + 60; + continue; + end; + // month + y := GetMonthNumber(s); + if (y > 0) and (month = 0) then + month := y; + end; + if year = 0 then + year := 1980; + if month < 1 then + month := 1; + if month > 12 then + month := 12; + if day < 1 then + day := 1; + x := MonthDays[IsLeapYear(year), month]; + if day > x then + day := x; + Result := Result + Encodedate(year, month, day); + zone := zone - TimeZoneBias; + x := zone div 1440; + Result := Result - x; + zone := zone mod 1440; + t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); + if zone < 0 then + t := 0 - t; + Result := Result - t; +end; + +{==============================================================================} + +function GetUTTime: TDateTime; +{$IF DEFINED(MSWINDOWS) or DEFINED(ULTIBO)} +{$IFNDEF FPC} +var + st: TSystemTime; +begin + GetSystemTime(st); + result := SystemTimeToDateTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: {$IFNDEF ULTIBO}Windows.TSystemTime{$ELSE}Ultibo.SYSTEMTIME{$ENDIF}; +begin + GetSystemTime(stw); + st.Year := stw.wYear; + st.Month := stw.wMonth; + st.Day := stw.wDay; + st.Hour := stw.wHour; + st.Minute := stw.wMinute; + st.Second := stw.wSecond; + st.Millisecond := stw.wMilliseconds; + result := SystemTimeToDateTime(st); +{$ENDIF} +{$ELSE MSWINDOWS} +{$IFNDEF FPC} +var + TV: TTimeVal; +begin + gettimeofday(TV, nil); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ELSE FPC} + {$IFDEF UNIX} +var + TV: TimeVal; +begin + fpgettimeofday(@TV, nil); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; + {$ELSE UNIX} + {$IFDEF OS2} +var + ST: TSystemTime; +begin + GetLocalTime (ST); + Result := SystemTimeToDateTime (ST); + {$ENDIF OS2} + {$ENDIF UNIX} +{$ENDIF FPC} +{$ENDIF MSWINDOWS} +end; + +{==============================================================================} + +function SetUTTime(Newdt: TDateTime): Boolean; +{$IF DEFINED(MSWINDOWS) or DEFINED(ULTIBO)} +{$IFNDEF FPC} +var + st: TSystemTime; +begin + DateTimeToSystemTime(newdt,st); + Result := SetSystemTime(st); +{$ELSE} +var + st: SysUtils.TSystemTime; + stw: {$IFNDEF ULTIBO}Windows.TSystemTime{$ELSE}Ultibo.SYSTEMTIME{$ENDIF}; +begin + DateTimeToSystemTime(newdt,st); + stw.wYear := st.Year; + stw.wMonth := st.Month; + stw.wDay := st.Day; + stw.wHour := st.Hour; + stw.wMinute := st.Minute; + stw.wSecond := st.Second; + stw.wMilliseconds := st.Millisecond; + Result := SetSystemTime(stw); +{$ENDIF} +{$ELSE MSWINDOWS} +{$IFNDEF FPC} +var + TV: TTimeVal; + d: double; + TZ: Ttimezone; + PZ: PTimeZone; +begin + TZ.tz_minuteswest := 0; + TZ.tz_dsttime := 0; + PZ := @TZ; + gettimeofday(TV, PZ); + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + {$IFNDEF POSIX} + Result := settimeofday(TV, TZ) <> -1; + {$ELSE} + Result := False; // in POSIX settimeofday is not defined? http://www.kernel.org/doc/man-pages/online/pages/man2/gettimeofday.2.html + {$ENDIF} +{$ELSE FPC} + {$IFDEF UNIX} +var + TV: TimeVal; + d: double; +begin + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + Result := fpsettimeofday(@TV, nil) <> -1; + {$ELSE UNIX} + {$IFDEF OS2} +var + ST: TSystemTime; +begin + DateTimeToSystemTime (NewDT, ST); + SetTime (ST.Hour, ST.Minute, ST.Second, ST.Millisecond div 10); + Result := true; + {$ENDIF OS2} + {$ENDIF UNIX} +{$ENDIF FPC} +{$ENDIF MSWINDOWS} +end; + +{==============================================================================} + +{$IFNDEF MSWINDOWS} +function GetTick: LongWord; +var + Stamp: TTimeStamp; +begin + Stamp := DateTimeToTimeStamp(Now); + Result := Stamp.Time; +end; +{$ELSE} +function GetTick: LongWord; +var + tick, freq: TLargeInteger; +{$IFDEF VER100} + x: TLargeInteger; +{$ENDIF} +begin + if Windows.QueryPerformanceFrequency(freq) then + begin + Windows.QueryPerformanceCounter(tick); +{$IFDEF VER100} + x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000; + Result := x.LowPart; +{$ELSE} + Result := Trunc((tick / freq) * 1000) and High(LongWord) +{$ENDIF} + end + else + Result := Windows.GetTickCount; +end; +{$ENDIF} + +{==============================================================================} + +function TickDelta(TickOld, TickNew: LongWord): LongWord; +begin +//if DWord is signed type (older Deplhi), +// then it not work properly on differencies larger then maxint! + Result := 0; + if TickOld <> TickNew then + begin + if TickNew < TickOld then + begin + TickNew := TickNew + LongWord(MaxInt) + 1; + TickOld := TickOld + LongWord(MaxInt) + 1; + end; + Result := TickNew - TickOld; + if TickNew < TickOld then + if Result > 0 then + Result := 0 - Result; + end; +end; + +{==============================================================================} + +function CodeInt(Value: Word): string; +begin + setlength(result, 2); + Result[1] := char(Value div 256); + Result[2] := char(Value mod 256); +// Result := Char(Value div 256) + Char(Value mod 256) +end; + +{==============================================================================} + +function DecodeInt(const Value: string; Index: integer): Word; +var + x, y: Byte; +begin + if Length(Value) > Index then + x := Ord(Value[Index]) + else + x := 0; + if Length(Value) >= (Index + 1) then + y := Ord(Value[Index + 1]) + else + y := 0; + Result := x * 256 + y; +end; + +{==============================================================================} + +function CodeLongInt(Value: LongInt): string; +var + x, y: word; +begin + // this is fix for negative numbers on systems where longint = integer + x := (Value shr 16) and integer($ffff); + y := Value and integer($ffff); + setlength(result, 4); + Result[1] := char(x div 256); + Result[2] := char(x mod 256); + Result[3] := char(y div 256); + Result[4] := char(y mod 256); +end; + +{==============================================================================} + +function DecodeLongInt(const Value: string; Index: integer): LongInt; +var + x, y: Byte; + xl, yl: Byte; +begin + if Length(Value) > Index then + x := Ord(Value[Index]) + else + x := 0; + if Length(Value) >= (Index + 1) then + y := Ord(Value[Index + 1]) + else + y := 0; + if Length(Value) >= (Index + 2) then + xl := Ord(Value[Index + 2]) + else + xl := 0; + if Length(Value) >= (Index + 3) then + yl := Ord(Value[Index + 3]) + else + yl := 0; + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + +function DumpStr(const Buffer: string): string; +var + n: Integer; +begin + Result := ''; + for n := 1 to Length(Buffer) do + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); +end; + +{==============================================================================} + +function DumpExStr(const Buffer: string): string; +var + n: Integer; + x: Byte; +begin + Result := ''; + for n := 1 to Length(Buffer) do + begin + x := Ord(Buffer[n]); + if x in [65..90, 97..122] then + Result := Result + ' +''' + char(x) + '''' + else + Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); + end; +end; + +{==============================================================================} + +procedure Dump(const Buffer: string; const DumpFile: string); +var + f: Text; +begin + AssignFile(f, DumpFile); + if FileExists(DumpFile) then + DeleteFile(DumpFile); + Rewrite(f); + try + Writeln(f, DumpStr(Buffer)); + finally + CloseFile(f); + end; +end; + +{==============================================================================} + +procedure DumpEx(const Buffer: string; const DumpFile: string); +var + f: Text; +begin + AssignFile(f, DumpFile); + if FileExists(DumpFile) then + DeleteFile(DumpFile); + Rewrite(f); + try + Writeln(f, DumpExStr(Buffer)); + finally + CloseFile(f); + end; +end; + +{==============================================================================} + +function TrimSPLeft(const S: string): string; +var + I, L: Integer; +begin + Result := ''; + if S = '' then + Exit; + L := Length(S); + I := 1; + while (I <= L) and (S[I] = ' ') do + Inc(I); + Result := Copy(S, I, MaxInt); +end; + +{==============================================================================} + +function TrimSPRight(const S: string): string; +var + I: Integer; +begin + Result := ''; + if S = '' then + Exit; + I := Length(S); + while (I > 0) and (S[I] = ' ') do + Dec(I); + Result := Copy(S, 1, I); +end; + +{==============================================================================} + +function TrimSP(const S: string): string; +begin + Result := TrimSPLeft(s); + Result := TrimSPRight(Result); +end; + +{==============================================================================} + +function SeparateLeft(const Value, Delimiter: string): string; +var + x: Integer; +begin + x := Pos(Delimiter, Value); + if x < 1 then + Result := Value + else + Result := Copy(Value, 1, x - 1); +end; + +{==============================================================================} + +function SeparateRight(const Value, Delimiter: string): string; +var + x: Integer; +begin + x := Pos(Delimiter, Value); + if x > 0 then + x := x + Length(Delimiter) - 1; + Result := Copy(Value, x + 1, Length(Value) - x); +end; + +{==============================================================================} + +function GetParameter(const Value, Parameter: string): string; +var + s: string; + v: string; +begin + Result := ''; + v := Value; + while v <> '' do + begin + s := Trim(FetchEx(v, ';', '"')); + if Pos(Uppercase(parameter), Uppercase(s)) = 1 then + begin + Delete(s, 1, Length(Parameter)); + s := Trim(s); + if s = '' then + Break; + if s[1] = '=' then + begin + Result := Trim(SeparateRight(s, '=')); + Result := UnquoteStr(Result, '"'); + break; + end; + end; + end; +end; + +{==============================================================================} + +procedure ParseParametersEx(Value: string; const Delimiter: string; const + Parameters: TStrings); +var + s: string; +begin + Parameters.Clear; + while Value <> '' do + begin + s := Trim(FetchEx(Value, Delimiter, '"')); + Parameters.Add(s); + end; +end; + +{==============================================================================} + +procedure ParseParameters(const Value: string; const Parameters: TStrings); +begin + ParseParametersEx(Value, ';', Parameters); +end; + +{==============================================================================} + +function IndexByBegin(Value: string; const List: TStrings): integer; +var + n: integer; + s: string; +begin + Result := -1; + Value := uppercase(Value); + for n := 0 to List.Count -1 do + begin + s := UpperCase(List[n]); + if Pos(Value, s) = 1 then + begin + Result := n; + Break; + end; + end; +end; + +{==============================================================================} + +function GetEmailAddr(const Value: string): string; +var + s: string; +begin + s := SeparateRight(Value, '<'); + s := SeparateLeft(s, '>'); + Result := Trim(s); +end; + +{==============================================================================} + +function GetEmailDesc(Value: string): string; +var + s: string; +begin + Value := Trim(Value); + s := SeparateRight(Value, '"'); + if s <> Value then + s := SeparateLeft(s, '"') + else + begin + s := SeparateLeft(Value, '<'); + if s = Value then + begin + s := SeparateRight(Value, '('); + if s <> Value then + s := SeparateLeft(s, ')') + else + s := ''; + end; + end; + Result := Trim(s); +end; + +{==============================================================================} + +function StrToHex(const Value: string): string; +var + n: Integer; +begin + Result := ''; + for n := 1 to Length(Value) do + Result := Result + IntToHex(Byte(Value[n]), 2); + Result := LowerCase(Result); +end; + +{==============================================================================} + +function IntToBin(Value: Integer; Digits: Byte): string; +var + x, y, n: Integer; +begin + Result := ''; + x := Value; + repeat + y := x mod 2; + x := x div 2; + if y > 0 then + Result := '1' + Result + else + Result := '0' + Result; + until x = 0; + x := Length(Result); + for n := x to Digits - 1 do + Result := '0' + Result; +end; + +{==============================================================================} + +function BinToInt(const Value: string): Integer; +var + n: Integer; +begin + Result := 0; + for n := 1 to Length(Value) do + begin + if Value[n] = '0' then + Result := Result * 2 + else + if Value[n] = '1' then + Result := Result * 2 + 1 + else + Break; + end; +end; + +{==============================================================================} + +function ParseURL(const URL: string; var Prot, User, Pass, Host, Port, Path, + Para: string): string; +var + x, y: Integer; + sURL: string; + s: string; + s1, s2: string; +begin + Prot := 'http'; + User := ''; + Pass := ''; + Host := ''; + Port := ''; + Path := ''; + Para := ''; + + x := Pos('://', URL); + if x > 0 then + begin + Prot := SeparateLeft(URL, '://'); + sURL := SeparateRight(URL, '://'); + end + else + sURL := URL; + s := UpperCase(Prot); + if s = 'HTTP' then + Port := '80' + else + if s = 'HTTPS' then + Port := '443' + else + if s = 'WS' then + Port := '80' + else + if s = 'WSS' then + Port := '443' + else + if s = 'FTP' then + Port := '21'; + x := Pos('@', sURL); + y := Pos('/', sURL); + if (x > 0) and ((x < y) or (y < 1))then + begin + s := SeparateLeft(sURL, '@'); + sURL := SeparateRight(sURL, '@'); + x := Pos(':', s); + if x > 0 then + begin + User := SeparateLeft(s, ':'); + Pass := SeparateRight(s, ':'); + end + else + User := s; + end; + x := Pos('/', sURL); + if x > 0 then + begin + s1 := SeparateLeft(sURL, '/'); + s2 := SeparateRight(sURL, '/'); + end + else + begin + s1 := sURL; + s2 := ''; + end; + if Pos('[', s1) = 1 then + begin + Host := Separateleft(s1, ']'); + Delete(Host, 1, 1); + s1 := SeparateRight(s1, ']'); + if Pos(':', s1) = 1 then + Port := SeparateRight(s1, ':'); + end + else + begin + x := Pos(':', s1); + if x > 0 then + begin + Host := SeparateLeft(s1, ':'); + Port := SeparateRight(s1, ':'); + end + else + Host := s1; + end; + Result := '/' + s2; + x := Pos('?', s2); + if x > 0 then + begin + Path := '/' + SeparateLeft(s2, '?'); + Para := SeparateRight(s2, '?'); + end + else + Path := '/' + s2; + if Host = '' then + Host := 'localhost'; +end; + +{==============================================================================} + +function ReplaceString(Value: string; const Search, Replace: string): string; +var + x, l, ls, lr: Integer; +begin + if (Value = '') or (Search = '') then + begin + Result := Value; + Exit; + end; + ls := Length(Search); + lr := Length(Replace); + Result := ''; + x := Pos(Search, Value); + while x > 0 do + begin + {$IFNDEF CIL} + l := Length(Result); + SetLength(Result, l + x - 1); + Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1); + {$ELSE} + Result:=Result+Copy(Value,1,x-1); + {$ENDIF} + {$IFNDEF CIL} + l := Length(Result); + SetLength(Result, l + lr); + Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr); + {$ELSE} + Result:=Result+Replace; + {$ENDIF} + Delete(Value, 1, x - 1 + ls); + x := Pos(Search, Value); + end; + Result := Result + Value; +end; + +{==============================================================================} + +function RPosEx(const Sub, Value: string; From: integer): Integer; +var + n: Integer; + l: Integer; +begin + result := 0; + l := Length(Sub); + for n := From - l + 1 downto 1 do + begin + if Copy(Value, n, l) = Sub then + begin + result := n; + break; + end; + end; +end; + +{==============================================================================} + +function RPos(const Sub, Value: String): Integer; +begin + Result := RPosEx(Sub, Value, Length(Value)); +end; + +{==============================================================================} + +function FetchBin(var Value: string; const Delimiter: string): string; +var + s: string; +begin + Result := SeparateLeft(Value, Delimiter); + s := SeparateRight(Value, Delimiter); + if s = Value then + Value := '' + else + Value := s; +end; + +{==============================================================================} + +function Fetch(var Value: string; const Delimiter: string): string; +begin + Result := FetchBin(Value, Delimiter); + Result := TrimSP(Result); + Value := TrimSP(Value); +end; + +{==============================================================================} + +function FetchEx(var Value: string; const Delimiter, Quotation: string): string; +var + b: Boolean; +begin + Result := ''; + b := False; + while Length(Value) > 0 do + begin + if b then + begin + if Pos(Quotation, Value) = 1 then + b := False; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end + else + begin + if Pos(Delimiter, Value) = 1 then + begin + Delete(Value, 1, Length(delimiter)); + break; + end; + b := Pos(Quotation, Value) = 1; + Result := Result + Value[1]; + Delete(Value, 1, 1); + end; + end; +end; + +{==============================================================================} + +function IsBinaryString(const Value: string): Boolean; +var + n: integer; +begin + Result := False; + for n := 1 to Length(Value) do + if CharInSet(Value[n], [#0 .. #8, #10 .. #31]) then + // ignore null-terminated strings + if not((n = Length(Value)) and (Value[n] = char(#0))) then + begin + Result := True; + Break; + end; +end; + +{==============================================================================} + +function PosCRLF(const Value: string; var Terminator: string): integer; +var + n, l: integer; +begin + Result := -1; + Terminator := ''; + l := length(value); + for n := 1 to L do + if CharInSet(Value[n], [#$0d, #$0a]) then + begin + Result := n; + Terminator := Value[n]; + if n <> l then + case value[n] of + #$0d: + if value[n + 1] = #$0a then + Terminator := #$0d + #$0a; + #$0a: + if value[n + 1] = #$0d then + Terminator := #$0a + #$0d; + end; + Break; + end; +end; + +{==============================================================================} + +Procedure StringsTrim(const Value: TStrings); +var + n: integer; +begin + for n := Value.Count - 1 downto 0 do + if Value[n] = '' then + Value.Delete(n) + else + Break; +end; + +{==============================================================================} + +function PosFrom(const SubStr, Value: String; From: integer): integer; +var + ls,lv: integer; +begin + Result := 0; + ls := Length(SubStr); + lv := Length(Value); + if (ls = 0) or (lv = 0) then + Exit; + if From < 1 then + From := 1; + while (ls + from - 1) <= (lv) do + begin + {$IFNDEF CIL} + if CompareMem(@SubStr[1],@Value[from],ls) then + {$ELSE} + if SubStr = copy(Value, from, ls) then + {$ENDIF} + begin + result := from; + break; + end + else + inc(from); + end; +end; + +{==============================================================================} + +{$IFNDEF CIL} +function IncPoint(const p: pbyte; Value: integer): pointer; +begin + Result := p; + Inc(pbyte(Result), Value); +end; +{$ENDIF} + +{==============================================================================} +//improved by 'DoggyDawg' +function GetBetween(const PairBegin, PairEnd, Value: string): string; +var + n: integer; + x: integer; + s: string; + lenBegin: integer; + lenEnd: integer; + str: string; + max: integer; +begin + lenBegin := Length(PairBegin); + lenEnd := Length(PairEnd); + n := Length(Value); + if (Value = PairBegin + PairEnd) then + begin + Result := '';//nothing between + exit; + end; + if (n < lenBegin + lenEnd) then + begin + Result := Value; + exit; + end; + s := SeparateRight(Value, PairBegin); + if (s = Value) then + begin + Result := Value; + exit; + end; + n := Pos(PairEnd, s); + if (n = 0) then + begin + Result := Value; + exit; + end; + Result := ''; + x := 1; + max := Length(s) - lenEnd + 1; + for n := 1 to max do + begin + str := copy(s, n, lenEnd); + if (str = PairEnd) then + begin + Dec(x); + if (x <= 0) then + Break; + end; + str := copy(s, n, lenBegin); + if (str = PairBegin) then + Inc(x); + Result := Result + s[n]; + end; +end; + +{==============================================================================} + +function CountOfChar(const Value: string; Chr: char): integer; +var + n: integer; +begin + Result := 0; + for n := 1 to Length(Value) do + if Value[n] = chr then + Inc(Result); +end; + +{==============================================================================} +// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application! +function UnquoteStr(const Value: string; Quote: Char): string; +var + n: integer; + inq, dq: Boolean; + c, cn: char; +begin + Result := ''; + if Value = '' then + Exit; + if Value = Quote + Quote then + Exit; + inq := False; + dq := False; + for n := 1 to Length(Value) do + begin + c := Value[n]; + if n <> Length(Value) then + cn := Value[n + 1] + else + cn := #0; + if c = quote then + if dq then + dq := False + else + if not inq then + inq := True + else + if cn = quote then + begin + Result := Result + Quote; + dq := True; + end + else + inq := False + else + Result := Result + c; + end; +end; + +{==============================================================================} + +function QuoteStr(const Value: string; Quote: Char): string; +var + n: integer; +begin + Result := ''; + for n := 1 to length(value) do + begin + Result := result + Value[n]; + if value[n] = Quote then + Result := Result + Quote; + end; + Result := Quote + Result + Quote; +end; + +{==============================================================================} + +procedure HeadersToList(const Value: TStrings); +var + n, x, y: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos(':', s); + if x > 0 then + begin + y:= Pos('=',s); + if not ((y > 0) and (y < x)) then + begin + s[x] := '='; + Value[n] := s; + end; + end; + end; +end; + +{==============================================================================} + +procedure ListToHeaders(const Value: TStrings); +var + n, x: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos('=', s); + if x > 0 then + begin + s[x] := ':'; + Value[n] := s; + end; + end; +end; + +{==============================================================================} + +function SwapBytes(Value: integer): integer; +var + S: string; + x, y, xl, yl: Byte; +begin + s := CodeLongInt(Value); + x := Ord(s[4]); + y := Ord(s[3]); + xl := Ord(s[2]); + yl := Ord(s[1]); + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + +function ReadStrFromStream(const Stream: TStream; len: integer): string; +var + x: integer; + Buf: TBytes; +begin + Setlength(Buf, Len); + x := Stream.Read(Buf, Len); + Setlength(Buf, x); + Result := StringOf(Buf); +end; + +{==============================================================================} + +procedure WriteStrToStream(const Stream: TStream; const Value: string); +{$IFDEF CIL} +var + buf: Array of Byte; +{$ENDIF} +begin +{$IFDEF CIL} + buf := BytesOf(Value); + Stream.Write(buf,length(Value)); +{$ELSE} + {$IFDEF UNICODE} + Stream.Write(MarshaledAString(TMarshal.AsAnsi(Value))^, Length(Value)); + {$ELSE} + Stream.Write(PAnsiChar(Value)^, Length(Value)); + {$ENDIF} +{$ENDIF} +end; + +{$IFDEF UNICODE} +procedure WriteStrToStream(const Stream: TStream; const Value: TSynaBytes); +begin + stream.WriteData(Value.Bytes, Value.Length); +end; +{$ENDIF} + +{==============================================================================} + +{$IFDEF POSIX} +function tempnam(const Path: PChar; const prefix: PChar): PChar; cdecl; + external libc name _PU + 'tempnam'; +{$ENDIF} + +function GetTempFile(const Dir, prefix: TFileName): TFileName; +{$IFNDEF FPC} +{$IFDEF MSWINDOWS} +var + Path: TFileName; + x: integer; +{$ENDIF} +{$ENDIF} +begin +{$IFDEF FPC} + Result := GetTempFileName(Dir, Prefix); +{$ELSE} + {$IFNDEF MSWINDOWS} + Result := tempnam(Pointer(Dir), Pointer(prefix)); + {$ELSE} + {$IFDEF CIL} + Result := System.IO.Path.GetTempFileName; + {$ELSE} + if Dir = '' then + begin + Path := StringOfChar(#0, MAX_PATH); + GetTempPath(Length(Path), PChar(Path)); + Path := PChar(Path); + end + else + Path := Dir; + x := Length(Path); + if Path[x] <> '\' then + Path := Path + '\'; + Result := StringOfChar(#0, MAX_PATH); + GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result)); + Result := PChar(Result); + SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY); + {$ENDIF} + {$ENDIF} +{$ENDIF} +end; + +{==============================================================================} + +function PadString(const Value: string; len: integer; Pad: char): string; +begin + if length(value) >= len then + Result := Copy(value, 1, len) + else + Result := Value + StringOfChar(Pad, len - length(value)); +end; + +{==============================================================================} + +function XorString(const Indata1: string; Indata2: string): string; +var + i: integer; +begin + Indata2 := PadString(Indata2, length(Indata1), #0); + Result := ''; + for i := 1 to length(Indata1) do + Result := Result + char(ord(Indata1[i]) xor ord(Indata2[i])); +end; + +{==============================================================================} + +function NormalizeHeader(Value: TStrings; var Index: Integer): string; +var + s, t: string; + n: Integer; +begin + s := Value[Index]; + Inc(Index); + if s <> '' then + while (Value.Count - 1) > Index do + begin + t := Value[Index]; + if t = '' then + Break; + for n := 1 to Length(t) do + if t[n] = #9 then + t[n] := ' '; + if not(CharInSet(char(t[1]), [' ', '"', ':', '='])) then + Break + else + begin + s := s + ' ' + Trim(t); + Inc(Index); + end; + end; + Result := TrimRight(s); +end; + +{==============================================================================} + +{pf} +procedure SearchForLineBreak(var APtr: PChar; AEtx: PChar; out ABol: PChar; + out ALength: integer); +begin + ABol := APtr; + while (APtr < AEtx) and not(CharInSet(APtr^, [#0, #10, #13])) do + Inc(APtr); + ALength := APtr - ABol; +end; +{/pf} + +{pf} +procedure SkipLineBreak(var APtr: PChar; AEtx: PChar); +begin + if (APtr < AEtx) and (APtr^ = #13) then + inc(APtr); + if (APtr < AEtx) and (APtr^ = #10) then + inc(APtr); +end; +{/pf} + +{pf} +procedure SkipNullLines(var APtr: PChar; AEtx: PChar); +var + bol: PChar; + lng: integer; +begin + while (APtr < AEtx) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + if lng>0 then + begin + APtr := bol; + Break; + end; + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilNullLine(var APtr: PChar; AEtx: PChar; ALines: TStrings); +var + bol: PChar; + lng: integer; + s: string; +begin + // Copying until body separator will be reached + while (APtr#0) do + begin + SearchForLineBreak(APtr,AEtx,bol,lng); + SkipLineBreak(APtr,AEtx); + if lng=0 then + Break; + SetString(s,bol,lng); + ALines.Add(s); + end; +end; +{/pf} + +{pf} +procedure CopyLinesFromStreamUntilBoundary(var APtr: PChar; AEtx: PChar; ALines: TStrings; const ABoundary: string); +var + bol: PChar; + lng: integer; + s: string; + //BackStop: string; + eob1: PChar; + eob2: PChar; +begin + //BackStop := '--'+ABoundary; + eob2 := nil; + // Copying until Boundary will be reached + while (APtr AEtx then + exit; + if strlcomp(MatchPos, #13#10, 2) = 0 then + inc(MatchPos,2); + if (MatchPos + 2 + lng) > AEtx then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if strlcomp(MatchPos, PChar(ABoundary), lng) <> 0 then + exit; + inc(MatchPos,Lng); + if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function MatchLastBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar; +var + MatchPos: PChar; +begin + Result := nil; + MatchPos := MatchBoundary(ABol, AEtx, ABoundary); + if not Assigned(MatchPos) then + exit; + if strlcomp(MatchPos,'--',2)<>0 then + exit; + inc(MatchPos,2); + if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + inc(MatchPos,2); + Result := MatchPos; +end; +{/pf} + +{pf} +function BuildStringFromBuffer(AStx, AEtx: PChar): string; +var + lng: integer; +begin + Lng := 0; + if Assigned(AStx) and Assigned(AEtx) then + begin + Lng := AEtx-AStx; + if Lng<0 then + Lng := 0; + end; + SetString(Result,AStx,lng); +end; +{/pf} + + +function CompareString(const Str1, Str2: String; + const CaseSensitive: Boolean = false): Boolean; +begin + if not CaseSensitive then + Result := Pos(LowerCase(Str1), LowerCase(Str2)) > 0 + else + Result := Pos(Str1, Str2) > 0; +end; + +{==============================================================================} +var + n: integer; +begin + for n := 1 to 12 do + begin + CustomMonthNames[n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n]; + MyMonthNames[0, n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n]; + end; +end. diff --git a/synsock.pas b/synsock.pas new file mode 100644 index 0000000..d6979a8 --- /dev/null +++ b/synsock.pas @@ -0,0 +1,93 @@ +{==============================================================================| +| Project : Ararat Synapse | 005.002.003 | +|==============================================================================| +| Content: Socket Independent Platform Layer | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2001-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +unit synsock; + +{$MINENUMSIZE 4} + +//old Delphi does not have MSWINDOWS define. +{$IFDEF WIN32} + {$IFNDEF MSWINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} +{$ENDIF} + +{$IFDEF CIL} + {$I ssdotnet.inc} +{$ELSE} + {$IFDEF MSWINDOWS} + {$I sswin32.inc} + {$ELSE} + {$IFDEF ULTIBO} + {$I ssultibo.inc} + {$ELSE} + {$IFDEF WINCE} + {$I sswin32.inc} //not complete yet! + {$ELSE} + {$IFDEF FPC} + {$IFDEF OS2} + {$I ssos2ws1.inc} + {$ELSE OS2} + {$I ssfpc.inc} + {$ENDIF OS2} + {$ELSE} + {$IFDEF POSIX} + {$I ssposix.inc} //experimental! + {$ELSE} + {$I sslinux.inc} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} +{$IFDEF POSIX} + {$I ssposix.inc} //experimental! +{$ENDIF} + +end. + diff --git a/tlntsend.pas b/tlntsend.pas new file mode 100644 index 0000000..1cac10f --- /dev/null +++ b/tlntsend.pas @@ -0,0 +1,364 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.001 | +|==============================================================================| +| Content: TELNET and SSH2 client | +|==============================================================================| +| Copyright (c)1999-2010, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2002-2010. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Telnet script client) + +Used RFC: RFC-854 +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit tlntsend; + +interface + +uses + SysUtils, Classes, + blcksock, synautil; + +const + cTelnetProtocol = '23'; + cSSHProtocol = '22'; + + TLNT_EOR = #239; + TLNT_SE = #240; + TLNT_NOP = #241; + TLNT_DATA_MARK = #242; + TLNT_BREAK = #243; + TLNT_IP = #244; + TLNT_AO = #245; + TLNT_AYT = #246; + TLNT_EC = #247; + TLNT_EL = #248; + TLNT_GA = #249; + TLNT_SB = #250; + TLNT_WILL = #251; + TLNT_WONT = #252; + TLNT_DO = #253; + TLNT_DONT = #254; + TLNT_IAC = #255; + +type + {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} + TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, + tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); + + {:@abstract(Class with implementation of Telnet/SSH script client.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} + TTelnetSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FBuffer: Ansistring; + FState: TTelnetState; + FSessionLog: Ansistring; + FSubNeg: Ansistring; + FSubType: Ansichar; + FTermType: Ansistring; + function Connect: Boolean; + function Negotiate(const Buf: Ansistring): Ansistring; + procedure FilterHook(Sender: TObject; var Value: AnsiString); + public + constructor Create; + destructor Destroy; override; + + {:Connects to Telnet server.} + function Login: Boolean; + + {:Connects to SSH2 server and login by Username and Password properties. + + You must use some of SSL plugins with SSH support. For exammple CryptLib.} + function SSHLogin: Boolean; + + {:Logout from telnet server.} + procedure Logout; + + {:Send this data to telnet server.} + procedure Send(const Value: string); + + {:Reading data from telnet server until Value is readed. If it is not readed + until timeout, result is @false. Otherwise result is @true.} + function WaitFor(const Value: string): Boolean; + + {:Read data terminated by terminator from telnet server.} + function RecvTerminated(const Terminator: string): string; + + {:Read string from telnet server.} + function RecvString: string; + published + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:all readed datas in this session (from connect) is stored in this large + string.} + property SessionLog: Ansistring read FSessionLog write FSessionLog; + + {:Terminal type indentification. By default is 'SYNAPSE'.} + property TermType: Ansistring read FTermType write FTermType; + end; + +implementation + +constructor TTelnetSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FSock.Owner := self; + FSock.OnReadFilter := FilterHook; + FTimeout := 60000; + FTargetPort := cTelnetProtocol; + FSubNeg := ''; + FSubType := #0; + FTermType := 'SYNAPSE'; +end; + +destructor TTelnetSend.Destroy; +begin + FSock.Free; + inherited Destroy; +end; + +function TTelnetSend.Connect: Boolean; +begin + // Do not call this function! It is calling by LOGIN method! + FBuffer := ''; + FSessionLog := ''; + FState := tsDATA; + FSock.CloseSocket; + FSock.LineBuffer := ''; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := FSock.LastError = 0; +end; + +function TTelnetSend.RecvTerminated(const Terminator: string): string; +begin + Result := FSock.RecvTerminated(FTimeout, Terminator); +end; + +function TTelnetSend.RecvString: string; +begin + Result := FSock.RecvTerminated(FTimeout, CRLF); +end; + +function TTelnetSend.WaitFor(const Value: string): Boolean; +begin + Result := FSock.RecvTerminated(FTimeout, Value) <> ''; +end; + +procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); +begin + Value := Negotiate(Value); + FSessionLog := FSessionLog + Value; +end; + +function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; +var + n: integer; + c: Ansichar; + Reply: Ansistring; + SubReply: Ansistring; +begin + Result := ''; + for n := 1 to Length(Buf) do + begin + c := Buf[n]; + Reply := ''; + case FState of + tsData: + if c = TLNT_IAC then + FState := tsIAC + else + Result := Result + c; + + tsIAC: + case c of + TLNT_IAC: + begin + FState := tsData; + Result := Result + TLNT_IAC; + end; + TLNT_WILL: + FState := tsIAC_WILL; + TLNT_WONT: + FState := tsIAC_WONT; + TLNT_DONT: + FState := tsIAC_DONT; + TLNT_DO: + FState := tsIAC_DO; + TLNT_EOR: + FState := tsDATA; + TLNT_SB: + begin + FState := tsIAC_SB; + FSubType := #0; + FSubNeg := ''; + end; + else + FState := tsData; + end; + + tsIAC_WILL: + begin + case c of + #3: //suppress GA + Reply := TLNT_DO; + else + Reply := TLNT_DONT; + end; + FState := tsData; + end; + + tsIAC_WONT: + begin + Reply := TLNT_DONT; + FState := tsData; + end; + + tsIAC_DO: + begin + case c of + #24: //termtype + Reply := TLNT_WILL; + else + Reply := TLNT_WONT; + end; + FState := tsData; + end; + + tsIAC_DONT: + begin + Reply := TLNT_WONT; + FState := tsData; + end; + + tsIAC_SB: + begin + FSubType := c; + FState := tsIAC_SBDATA; + end; + + tsIAC_SBDATA: + begin + if c = TLNT_IAC then + FState := tsSBDATA_IAC + else + FSubNeg := FSubNeg + c; + end; + + tsSBDATA_IAC: + case c of + TLNT_IAC: + begin + FState := tsIAC_SBDATA; + FSubNeg := FSubNeg + c; + end; + TLNT_SE: + begin + SubReply := ''; + case FSubType of + #24: //termtype + begin + if (FSubNeg <> '') and (FSubNeg[1] = #1) then + SubReply := #0 + FTermType; + end; + end; + Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); + FState := tsDATA; + end; + else + FState := tsDATA; + end; + + else + FState := tsData; + end; + if Reply <> '' then + Sock.SendString(TLNT_IAC + Reply + c); + end; + +end; + +procedure TTelnetSend.Send(const Value: string); +begin + Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); +end; + +function TTelnetSend.Login: Boolean; +begin + Result := False; + if not Connect then + Exit; + Result := True; +end; + +function TTelnetSend.SSHLogin: Boolean; +begin + Result := False; + if Connect then + begin + FSock.SSL.SSLType := LT_SSHv2; + FSock.SSL.Username := FUsername; + FSock.SSL.Password := FPassword; + FSock.SSLDoConnect; + Result := FSock.LastError = 0; + end; +end; + +procedure TTelnetSend.Logout; +begin + FSock.CloseSocket; +end; + + +end. diff --git a/tzutil.pas b/tzutil.pas new file mode 100644 index 0000000..7824028 --- /dev/null +++ b/tzutil.pas @@ -0,0 +1,702 @@ +//Unit with timezone support for some Freepascal platforms. +//Tomas Hajny + +unit tzutil; + + +interface + +type + DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX); + +(* Initialized to default values *) +const + TZName: string = ''; + TZDSTName: string = ''; + TZOffset: longint = 0; + DSTOffset: longint = 0; + DSTStartMonth: byte = 4; + DSTStartWeek: shortint = 1; + DSTStartDay: word = 0; + DSTStartSec: cardinal = 7200; + DSTEndMonth: byte = 10; + DSTEndWeek: shortint = -1; + DSTEndDay: word = 0; + DSTEndSec: cardinal = 10800; + DSTStartSpecType: DSTSpecType = DSTMonthWeekDay; + DSTEndSpecType: DSTSpecType = DSTMonthWeekDay; + +function TZSeconds: longint; +(* Return current offset from UTC in seconds while respecting DST *) + +implementation + +uses + Dos; + +function TZSeconds: longint; +const + MonthDays: array [1..12] of byte = + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + MonthEnds: array [1..12] of word = + (31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365); +var + Y, Mo, D, WD, H, Mi, S, S100: word; + MS, DS, ME, DE: byte; + L: longint; + Second: cardinal; + AfterDSTStart, BeforeDSTEnd: boolean; + +function LeapDay: byte; +begin + if (Y mod 400 = 0) or (Y mod 100 <> 0) and (Y mod 4 = 0) then + LeapDay := 1 + else + LeapDay := 0; +end; + +function FirstDay (MM: byte): byte; +(* What day of week (0-6) is the first day of month MM? *) +var + DD: longint; +begin + if MM < Mo then + begin + DD := D + MonthEnds [Pred (Mo)]; + if MM > 1 then + Dec (DD, MonthEnds [Pred (MM)]); + if (MM <= 2) and (Mo > 2) then + Inc (DD, LeapDay); + end + else + if MM > Mo then + begin + DD := - MonthDays [Mo] + D - MonthEnds [Pred (MM)] + MonthEnds [Mo]; + if (Mo <= 2) and (MM > 2) then + Dec (DD, LeapDay); + end + else +(* M = MM *) + DD := D; + DD := WD - DD mod 7 + 1; + if DD < 0 then + FirstDay := DD + 7 + else + FirstDay := DD mod 7; +end; + +begin + TZSeconds := TZOffset; + if DSTOffset <> TZOffset then + begin + GetDate (Y, Mo, D, WD); + GetTime (H, Mi, S, S100); + Second := cardinal (H) * 3600 + Mi * 60 + S; + + if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay) + then + begin + MS := DSTStartMonth; + if DSTStartSpecType = DSTMonthDay then + DS := DSTStartDay + else + begin + DS := FirstDay (DSTStartMonth); + if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then + if DSTStartDay < DS then + DS := DSTStartWeek * 7 + DSTStartDay - DS + 1 + else + DS := Pred (DSTStartWeek) * 7 + DSTStartDay - DS + 1 + else +(* Last week in month *) + begin + DS := DS + MonthDays [MS] - 1; + if MS = 2 then + Inc (DS, LeapDay); + DS := DS mod 7; + if DS < DSTStartDay then + DS := DS + 7 - DSTStartDay + else + DS := DS - DSTStartDay; + DS := MonthDays [MS] - DS; + end; + end; + end + else + begin +(* Julian day *) + L := DSTStartDay; + if (DSTStartSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + MS := 1; + DS := L; + end + else + if (L <= 59) or + (DSTStartSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + MS := 2; + DS := DSTStartDay - 31; + end + else + begin + MS := 3; + while (MS < 12) and (MonthEnds [MS] > L) do + Inc (MS); + DS := L - MonthEnds [Pred (MS)]; + end; + end; + + if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then + begin + ME := DSTEndMonth; + if DSTEndSpecType = DSTMonthDay then + DE := DSTEndDay + else + begin + DE := FirstDay (DSTEndMonth); + if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then + if DSTEndDay < DE then + DE := DSTEndWeek * 7 + DSTEndDay - DE + 1 + else + DE := Pred (DSTEndWeek) * 7 + DSTEndDay - DE + 1 + else +(* Last week in month *) + begin + DE := DE + MonthDays [ME] - 1; + if ME = 2 then + Inc (DE, LeapDay); + DE := DE mod 7; + if DE < DSTEndDay then + DE := DE + 7 - DSTEndDay + else + DE := DE - DSTEndDay; + DE := MonthDays [ME] - DE; + end; + end; + end + else + begin +(* Julian day *) + L := DSTEndDay; + if (DSTEndSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + ME := 1; + DE := L; + end + else + if (L <= 59) or + (DSTEndSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + ME := 2; + DE := DSTEndDay - 31; + end + else + begin + ME := 3; + while (ME < 12) and (MonthEnds [ME] > L) do + Inc (ME); + DE := L - MonthEnds [Pred (ME)]; + end; + end; + + if Mo < MS then + AfterDSTStart := false + else + if Mo > MS then + AfterDSTStart := true + else + if D < DS then + AfterDSTStart := false + else + if D > DS then + AfterDSTStart := true + else + AfterDSTStart := Second > DSTStartSec; + if Mo > ME then + BeforeDSTEnd := false + else + if Mo < ME then + BeforeDSTEnd := true + else + if D > DE then + BeforeDSTEnd := false + else + if D < DE then + BeforeDSTEnd := true + else + BeforeDSTEnd := Second < DSTEndSec; + if AfterDSTStart and BeforeDSTEnd then + TZSeconds := DSTOffset; + end; +end; + +procedure InitTZ; +const + TZEnvName = 'TZ'; + EMXTZEnvName = 'EMXTZ'; +var + TZ, S: string; + I, J: byte; + Err: longint; + GnuFmt: boolean; + ADSTStartMonth: byte; + ADSTStartWeek: shortint; + ADSTStartDay: word; + ADSTStartSec: cardinal; + ADSTEndMonth: byte; + ADSTEndWeek: shortint; + ADSTEndDay: word; + ADSTEndSec: cardinal; + ADSTStartSpecType: DSTSpecType; + ADSTEndSpecType: DSTSpecType; + ADSTChangeSec: cardinal; + + function ParseOffset (OffStr: string): longint; + (* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *) + var + TZShiftHH, TZShiftDir: shortint; + TZShiftMI, TZShiftSS: byte; + N1, N2: byte; + begin + TZShiftHH := 0; + TZShiftMI := 0; + TZShiftSS := 0; + TZShiftDir := 1; + N1 := 1; + while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do + Inc (N1); + Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err); + if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then + begin +(* Normalize the hour offset to -12..11 if necessary *) + if TZShiftHH > 11 then + Dec (TZShiftHH, 24) else + if TZShiftHH < -12 then + Inc (TZShiftHH, 24); + if TZShiftHH < 0 then + TZShiftDir := -1; + if (N1 <= Length (OffStr)) then + begin + N2 := Succ (N1); + while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do + Inc (N2); + Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err); + if (Err = 0) and (TZShiftMI <= 59) then + begin + if (N2 <= Length (OffStr)) then + begin + Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err); + if (Err <> 0) or (TZShiftSS > 59) then + TZShiftSS := 0; + end + end + else + TZShiftMI := 0; + end; + end + else + TZShiftHH := 0; + ParseOffset := longint (TZShiftHH) * 3600 + + TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS); + end; + +begin + TZ := GetEnv (TZEnvName); + if TZ = '' then + TZ := GetEnv (EMXTZEnvName); + if TZ <> '' then + begin + TZ := Upcase (TZ); +(* Timezone name *) + I := 1; + while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do + Inc (I); + TZName := Copy (TZ, 1, Pred (I)); + if I <= Length (TZ) then + begin +(* Timezone shift *) + J := Succ (I); + while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do + Inc (J); + TZOffset := ParseOffset (Copy (TZ, I, J - I)); +(* DST timezone name *) + I := J; + while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do + Inc (J); + if J > I then + begin + TZDSTName := Copy (TZ, I, J - I); +(* DST timezone name provided; if equal to the standard timezone *) +(* name then DSTOffset is set to be equal to TZOffset by default, *) +(* otherwise it is set to TZOffset - 3600 seconds. *) + if TZDSTName <> TZName then + DSTOffset := -3600 + TZOffset + else + DSTOffset := TZOffset; + end + else + begin + TZDSTName := TZName; +(* No DST timezone name provided => DSTOffset is equal to TZOffset *) + DSTOffset := TZOffset; + end; + if J <= Length (TZ) then + begin +(* Check if DST offset is specified here; *) +(* if not, default value set above is used. *) + if TZ [J] <> ',' then + begin + I := J; + Inc (J); + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + DSTOffset := ParseOffset (Copy (TZ, I, J - I)); + end; + if J < Length (TZ) then + begin + Inc (J); +(* DST switching details *) + case TZ [J] of + 'M': + begin +(* Mmonth.week.dayofweek[/StartHour] *) + ADSTStartSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end; + 'J': + begin +(* Jjulianday[/StartHour] *) + ADSTStartSpecType := DSTJulianX; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end + else + begin +(* Check the used format first - GNU libc / GCC / EMX expect *) +(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]"; *) +(* if more than one comma (',') is found, the following format is assumed: *) +(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond, *) +(* EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *) + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + S := Copy (TZ, I, J - I); + if J < Length (TZ) then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + GnuFmt := J > Length (TZ); + end + else + Exit; + if GnuFmt then + begin + ADSTStartSpecType := DSTJulian; + J := Pos ('/', S); + if J = 0 then + begin + Val (S, ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + end + else + begin + if J = Length (S) then + Exit; + Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end; + J := I; + end + else + begin + Val (S, ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or + (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (DSTStartWeek = 0) then + begin + if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31) + or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11]) + or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then + Exit; + ADSTStartSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) then + Exit; + ADSTStartSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5) + or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (DSTEndWeek = 0) then + begin + if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31) + or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11]) + or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then + Exit; + ADSTEndSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + ADSTEndSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) or (J >= Length (TZ)) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err); + if (Err = 0) and (ADSTChangeSec < 86400) then + begin +(* Format complete, all checks successful => accept the parsed values. *) + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + DSTOffset := TZOffset - ADSTChangeSec; + end; +(* Parsing finished *) + Exit; + end; + end; + end; +(* GnuFmt - DST end specification *) + if TZ [J] = 'M' then + begin +(* Mmonth.week.dayofweek *) + ADSTEndSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + end + else + begin + if TZ [J] = 'J' then + begin +(* Jjulianday *) + if J = Length (TZ) then + Exit; + Inc (J); + ADSTEndSpecType := DSTJulianX + end + else + ADSTEndSpecType := DSTJulian; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX) + or (ADSTEndDay > 365) then + Exit; + end; + if (J <= Length (TZ)) and (TZ [J] = '/') then + begin + if J = Length (TZ) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) then + Exit + else + ADSTEndSec := ADSTEndSec * 3600; + end + else + (* Use the preset default *) + ADSTEndSec := DSTEndSec; + +(* Format complete, all checks successful => accept the parsed values. *) + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + end; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + end; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + end; + end + else + DSTOffset := -3600 + TZOffset; + end; + end; +end; + + +begin + InitTZ; +end.