From 787674f18898e365073cdad98ac891b04509dc84 Mon Sep 17 00:00:00 2001 From: Tobias Boege Date: Sun, 23 Feb 2020 15:54:16 +0100 Subject: [PATCH] gb.test.tap: New component for reading and writing TAP [GB.TEST.TAP] * NEW: Add new component based on an old fork of gb.test. --- comp/src/gb.test.tap/.component | 4 + comp/src/gb.test.tap/.directory | 2 + comp/src/gb.test.tap/.icon.png | Bin 0 -> 10933 bytes comp/src/gb.test.tap/.project | 10 + comp/src/gb.test.tap/.src/Assert.class | 222 ++++++++++++++++++ comp/src/gb.test.tap/.src/Main.module | 37 +++ comp/src/gb.test.tap/.src/SampleTest.module | 36 +++ comp/src/gb.test.tap/.src/Tap/Tap.module | 9 + comp/src/gb.test.tap/.src/Tap/TapParser.class | 160 +++++++++++++ .../src/gb.test.tap/.src/Tap/TapPrinter.class | 157 +++++++++++++ comp/src/gb.test.tap/.src/TestHarness.class | 213 +++++++++++++++++ comp/src/order | 2 +- 12 files changed, 851 insertions(+), 1 deletion(-) create mode 100644 comp/src/gb.test.tap/.component create mode 100644 comp/src/gb.test.tap/.directory create mode 100644 comp/src/gb.test.tap/.icon.png create mode 100644 comp/src/gb.test.tap/.project create mode 100644 comp/src/gb.test.tap/.src/Assert.class create mode 100644 comp/src/gb.test.tap/.src/Main.module create mode 100644 comp/src/gb.test.tap/.src/SampleTest.module create mode 100644 comp/src/gb.test.tap/.src/Tap/Tap.module create mode 100644 comp/src/gb.test.tap/.src/Tap/TapParser.class create mode 100644 comp/src/gb.test.tap/.src/Tap/TapPrinter.class create mode 100644 comp/src/gb.test.tap/.src/TestHarness.class diff --git a/comp/src/gb.test.tap/.component b/comp/src/gb.test.tap/.component new file mode 100644 index 000000000..4dec8c554 --- /dev/null +++ b/comp/src/gb.test.tap/.component @@ -0,0 +1,4 @@ +[Component] +Key=gb.test.tap +Version=3.14.90 +Authors=(C) 2018-2020 Tobias Boege diff --git a/comp/src/gb.test.tap/.directory b/comp/src/gb.test.tap/.directory new file mode 100644 index 000000000..06dab1c8a --- /dev/null +++ b/comp/src/gb.test.tap/.directory @@ -0,0 +1,2 @@ +[Desktop Entry] +Icon=./.icon.png diff --git a/comp/src/gb.test.tap/.icon.png b/comp/src/gb.test.tap/.icon.png new file mode 100644 index 0000000000000000000000000000000000000000..eedc7d8863854cb8646b25127e14db92ddf35ed5 GIT binary patch literal 10933 zcmb_?cQjn#xAvLA=puSAi6DtCO0+=)5hX(OE>R+S^fr2LA&E}(UZO-ddUPT(qIVKR zXE4ln{O)(}x9}Q|I7wSr+L<~d#0FXXYR(J^j5b$3JKmY@O zj9iMXz#l>Gg zwxu?ng8-53_x;biI?_3V$CpAc)iJ}S*%_D^K>~dV4OLo(Rn%a>GFPkVh5og%sYb*E z$HVN0_u`zhQ1$zX2?;Nye|q+Jbogti5GsFS%{JAD>np(WSqyI4(XDly{|>+$$E(W( zu_+qq0l-~$rw^z2g@(W+C-&#jbR&(7yIQp%@fXZdzH6Th4oM7a_N$%bFvHp1$0$B_NvH`i}fja6frTtK4od&i&V6G-!#eD zVfBL{MM@(xpDclLQ}qrWpef;S==Yey#b6H)UdCa3bi8XZ&b}-B&M(U?jwM)8zqo9!55@1T30BB>N#(SQCFSu;_fCs{ z3`S{8ymM^BVy`C`uO^Q&pJ~Su6C=LTBvIIik(P^`PhYNQ_xA8eqY7(&ne{et*}OT~ z$nSud4IYHDntTUFHW3^%@5H(YKn|#&Aga$-jh0G_Izi$ zS((`PeSQ!2wZXr50?rJd-$HD33}L@qJ#xxx`Z?jO*_d90)jrlOxpn;dd@VZ$N7di| zT-c?1MH}0J_FIuKC{~R#HY7+&4PQYYe!g$)@m@;OL3%4NE2&L)kuJ>K;*HyO2R3E} z(nDy}jF-duFgB5#J8lZDe~y`0OJ|r%+c>I?q;(ys;tdnT`pZ8QR@I|#!t&z_Qq z)TnkI#{@Ak!Vz~q<=jCVNq=rdmuuF+;qB$;f)|(69jj{{2e$Fu^VZ+LQi)W(@wAV^ zC!b7>2K``5r)R%^f8u)bF7_ftE8vq~fS>x~c++bhX8iHAY_$wsJ&LcMeC$PiLUHl& z)MNcPu}l`xt^9D}ASkEz*Nl~%3 ztmBmE=!GpY`xz*P}w4b{h#9=W$?7bWktQ4no@|AJ|kX0t;`{3p6MIz@fvCZ>*9aOQBgITxsN^B z_UdKZeETvpzpcpXF6RocuF_g^5MtEgDw;?*9-z*tIF?E$*^xn-LO`fm!P`jC`2r6I zf&e%Ch_4fxAS|86(yx+9d)@qgWto@A*+w|Kq%L!Y7D5N&^1Dvd} zX(c>?gjNSw_CAq=M%MV6ce06>v~N{ZlFJDq1+g6w5CXFMbSZ03d;DEuLXq5ljd8z- zy$(N<%iCQ$!#gmSQY^N2qW&{uh!wja;u(VorJ5tv6?_ECUxy|9=v;nW8-YW2_gkQA z^62N@&Ln+==32I#kYJQx%+#K6wF{BU9gVRf^nU*~bb8t+I){k_mzza4Mu6WtP%C+% z~>SLHR5nGRofg_mM{pD28A*i^>T8A zuc;8&#E!VgaS+qLRC%b3aD8kAiGgOWE*3SiSe81NL*&iIx7qf6^hfMsdvQK|+_wf~ zQm_OOZ`QlMEe2fbj)+k~qRdk)=(e5-dS7u6n+X+}ikiP)XG_r7nJYq>G{1H^4m}#E z`VmaQY|aV zfT|ix1t%7=WG3M=uNQk-t1^C$ijJ~dSH9mLk9U}y!=r!uyyiPE0jJBedz$%t#3LQD zvmHIBla9{-a!Vt9awmpLds!7Wglu6bf)8WvQvO{@!=La(5@o>9FH%0t7+OrwLBsj( zQTEX^BAJd7x0z1a_WHKUQJHw4*_~T2g#h^iiq!8~k=&fvT&RDMAk*nSE%q|NXqPRb zU}c2{c~8q#J5iO+{M{jrR+O(x#h`vu>#1jIbr!}lt)p?g7^$3XILe`FSZUNqr22+C zA^rNh2>jtwF21k%pV>A>Ug`r3{X%SSVDQ&>b#q?hIoa4(iFnzPOHAqh*e^fMx?q1! zX%Y~wSt$4YgCraMaTm+z;Uo4&6%Cr~#Po9@M+ELd{4`mOI!KT2(k@L6u8|) zZ=8nl+IR4sP*23BD=(|r92~A?EAQ5PaM!Ims2PA8+|x67Fs!)w+1%hOPw7lJ+XAAX z4tUg1z-gRZj3=f-5F_)#qAMGfc)jA0MZ5Psk&SL!QK(%=!_NOrjW7YhmIy=$br|Z# zo|t~MnhifZe|AJUH1@;b#u(r}dC}_7+vvq2+iTy$&zAT}I>^^aqs}9y{_(Mfq`lS= zKQ=WKFToM0;DUymMWGPQJ0GcEj81+&+LeehHE1t;2xC_oia!xDy)rVcDnD1!2@C;3 zqHv0X*kd?-9w+691o-p*!1TB+snFoG5jONL&ro`KS2%M$djDGk1wrf2I56AIXPW97 zKNq`9`S479*&DZJ$B39%){>!=R5v3^Q-O76@AK2d_^h5#jj`8))s_27{7*leVEg+FUC{)TxqNy%R#lv z2PQyh32c(cug$vu8AJ>aA#+u#TM2A16907{3~r}B#gogFuQXu>1WZzVnPPq_e+fVS^T*D@Pg{@?x$Qjhm)J30A1C&*3cJ)V8rZ(XJ(x zjCK$kamF#A`bQe%1athZ(_!KAB!Sq-Q1) zPv_*`ou|of5};@_zO0V+ z1_{ACx!s%*O)u$*bJ(izQx*pBH{(u~^rJY2q9#Rk4AE^Ga5?v5kvC+K1w}$M2&-~G zx&^73>_IB?53vKpvjY3!0cd<#21Mj?Xx}sP=p1hvBMA)an7(;`dOdF+#LT=9&3BN&zVEncAt{An1T`UcW8<^CQ{041?O%D zEAaX~aGx8kWOVC+JtQMES(Ya*{qhY_2Yl=S0T!rpLNxMeFF?g3sfz6Ua(2!n&!0VE zJE9eo3TmVR=P~;fS*7WZEuPT`yF6l~lN$~M`8hnA&yoohcj8XmarVdYqsi@rgNcu^ zAhO_o1r`9%8l`|^e9Na#grq`-)#IqidxTt8X>p82Ll+$-Evtxyu#t8Igb3He|LogQ zt^9B(Oje~6zH;I0K+A?U#U6(BT`e*ZUEfAge+Br6D9M*QU&RNpEf5evO~~n)pj4N4 zEAPLC7?IyRlIm&*{9YK_6eJ5`t3R z?Qb4IUoB#<%2SNbmATI^lMUiT`aMJ;!D=gn&>eRB=E4`0Fo(hi$T?Kl^5r9e zB;iI*rID3=9vpjAS4CK`Au0YhM$wtd&@@{F^)EkCJk*p|YdVbq{d-JB+=3fpvx7)a_t5F4`3D^V*5u1$CQQo*>bE4X2=?mi%m9+nY7UdZ*g#w)1-bPgYVnT} z`oat`=8o^#I@w?5A5r&u#+0Tcfv$%>%sI>t-X}0>CKSe@l^QxritjcXV$Y*Uu3XZ- z%BEf;9I?N?0A%l--fYV}LrxhX{1GoDnDm9MGQb1r7Vq{@g0xR>uWmMNz=@KYRIi07 zROogtZeQ;Wk(~z9U2*jGr>nKjo|>U(IDniL79anZ4o~M0B}r+iy)e2y`j_mkyHzaU z!RF%tD#>?`9B;|{)}Z=VGg;baSS?WTw4yLVqy{dAL!L*wotdK41Zn0POZXiuStF6{ ztgE`0Pkb9@`>V*p#EG;x;p-ql@}c1a>9s{Dvhz#7r}c*lsqSzQh}6vl&iD7$$c zAB1bVd+Xr09rd3@W)sz;?SX^Bv-in_J7kvA8J4x8h>^!kPo(*3p&A>drqp5uo-P7C z)>W5imw*UqxMB(+P@2^#_%rwcu!%zmPPl$9{O;@tW~z*jW$)OTs=aB$8t}ArP$rBZ zj@c7Xz1gzR{li@Lk1Vaj5)i^1%0kb&$!>mkZ?uIYVplFgfH`)~j3mw$DM(89=zJ4e z0c(ZkwtnBV_K%!(G#D(8&akxivhh*hIo6DLz>hs2{v==8gf%-6q zwFnIV2>vtt&8SnmY|l2U)#cLg%ZGemI4T3PSL9U}w@psvnP7q#jwhV=VthAV%fBKX zwV>bHL2A;i4qZW{hGgf3#;f`LTa*czV1r%g-ffxoIYzS<)-H|s_~9jzxYQQ5*N|bn zzXWx%b$g41lv0n64|c!A`)6c6K7Xur?KCOs+_Jp1`;lS6^r%|@n>jtx6*r!BQ`pC^ z5tW7+dFJWWBw?!DL){uLdxZ5EDUfV~``~cu{;uvQ?IZ57FWHqzy+RW}*B5|9Qofp;ic45)R_;b>l z1#-yeQWj1#_JNmh0Y)5QC37CIszV8HpYO^nj25T%{7t-X+~2Q@kMq8(E=85b+GZN| z?-7%4;{;M?9s=x;=3z=zwmGf!ppgk%iuX^CK1O5;^fvdK)7Sc$Ci1^z;G`$R(3!H5 z97Lnqd=FXA&bb7S_9m)HQ;sMA>Tp~nlyH*Abd>Rq>ew&L;PGbTE06t_Go6FgS>Dzu zm&Dgl5NdsE#E{Vr5$aiDsGmGIj`c>qt-p~)XS&V-1u(#Kfi%i&X~-nPBzZI+2!8bN zg8b*v(kc%Dp+ahpJG{%Z{qNGzyi69;#e*r2s120OP?32$2e1Jq2)taPfS(F!Z=ln# z{!+VT|CX>l$DapI^{_Fa{ZiHyeKF)WB^k0H%>|>pRXjsC{4?FRo*q*V7iOiHa;JoA z9G#rPQjH*OkIqlnx(s>GhMkM#@2KE4Yrf>Mz24qs0hbgfvA`Af^^olqNQ;XswCpk% zZw@JygPH{@lpq&mQ?Z)vrySr5T`)Y_ZxaE-ry|HagIyWV6bAk(0<&aBTe#4Il33*Lni2s0~ zQ8H%#{2wqIOyJC!@GPU`3i9U1tt66ejwcf9xYAj>av@cx_)nvbUcnW(RLKk9KHKxE z5m%aQ7=O>Br~5O1t?&u>9$yP(H~u+}l#H}2&dokaBi&?@aeBbv?F{=(3<1WNPikok zJb&L3R27<{PZ1<=Zy-*1cCRt)S(v!i?%?}%^Aw`vJgRW>n9VkF(|@=2=QRW9Gt?^3W#1SWXNR*1P5y` zz2Wb1;FJ2G%BGA*(zj&rSLF5(SeW3GnrKzJmCx~k{`?o^x z!<;2tbM|`n?CEW0IHiUVmIC9L>|5Y^5yKB5!t8?25BRMSBd=Johq%?GarJ4T;Kh-o z+;g04@qpvPIcy*ck@d!GsvcPSc_boVdX2%C3*tWu-wIiUn)#5MTa)LqzM(Y;$rmII z`($U)J0eM=1v7JaLGBd!*cPHO@@QYDHZ0RB#w1_$=x8bJZ6-WtE~xf`^lzMWl{e&i zv&wxr1-7D^EJ0P4{aNrlQ0hv*w%VX}WARh@%9(Hl%!rL=v7~>Eq{K{oyDIfry&_yC z^len4A;fJK89c=xVIDMZ9wL`d6gWy$XB(ZnTP%W?nv8b4|J;cID$74Q9(|P>*Fhk< zsptAJRM-)6lLU+qcoqWG)2^y<3IwmMx&LVw*BQXoYr51@jNU*Q8UoKyepKxJQd-!_FpYX7`I9j)>uS>a=i|-RtNvwSl4|%O z(U#;zj>%c+VsQgC%fF|^txto+;h>KQf(_=nf4`fz59a7TazIox$DX8xew1=5@>z47 zviJ24pmr27zJV?fL`>GMfa3?ZIbrU}1y_cM~xWh_6-D$0JN)|Kl_5~nuSXO)SI zZ2iKv1O?f1#@ENhp}mnkFi(Qc&45>EcXOj6%^5-QfSxTK}@b#4u57#QB9V~X9P z+(08xd~Z4<5ok6K>hPNHw{DSspSxzXX+`n2KjSm=@lj6ZuL}{G*=7v)h}eQS-O5-N z^YZ6Q941(8yrrgiA($fZzcG+8x%O4wr7fH}6V?Y@Ic`&Qi}#+gb$KYsWO*zOZ?g0a zQYXCZswKg-4Qm;haA=SFB04(0;ljy5@#QamkoFRCZ2R~OhPDW}L4^`MmPyk*;$#Q0 zjMiB}LB|`j;qfa09&4*70$ptC)(%)>MdkW%7o znt#S%Oj0bybpPFiOA#~c>=i+{T+pMI*3!12d@F{=$@k7he{x0b76n)2U(lGvp`V2n zd2ME?C)^ob*oiMP4m8R5!dfOSFQ!s07E?VRlMFa1UO~IGb7*66k!2rdpdnO{y zC;DJ*@#(+F(J{=Ath74XLnd z&Z=>|V|}|}vDE!ccK-6iv=p_jY}C*zf!;*cJjTL(>)}gX>M&l|u6#rNpX$~FJ_u`0sO%?h>fZ!l_T~zoiNt(rVC8rTz>o2XY2Ve+QdVpkrrSjMQLbFmL_F))UUyZw{f@}w{M4~RA?3@d} z6dd}+9vv+Aai_9LR8)!)q=F9Z@S9QvtV)%Z|475=fYC$`fwwD{+oX@|oAIhBF1E)Y zeaQ`vrr+&yO3flA%S7t)QA;4NbEe|lQYxJ~%Y8uTrXiDlBtJRJIVMTr`pBMgJ1Z7E ziw$<{)D)7zt@Ln{{zTbDB?akz@xa@d)^J3_e--evVV! zK4mNom*x}eXRok_4RaE1!!Ic7Y|D6?ei;#OXZ<*3%!-X|j%_GA{c9P+uKKhc$0=kl z4oYIJm!kcRwDsHH<=_*Ts5HKaE1~!GE6~xO%v=$|I`06Ae5kd^qV@S>-u|vOYD(~I z8x6_M)>pssa9Zl$pHvmW45#~Z%HQEVrI*@m{yPKHz11e1*!#G=)x7xEvD=XB&|^8k zQ}l0x$`o@bVHQ&x zJ3#no0$h==AB?Q0!eBg4-uE3ib2?FRY&|9X^_J$JsPUtBl#7N{d6b+tJeoyenz>j_ zo-7!5UZ9ul+3iC55AT}Em%PSDMVc7m3)~qTW;hMvA{*?!?563Bs9iMM)A05YiLnLz zOJNdP%fLv4Eoj6CTsY{d%6mO(ZVwgQis zDb@NjO3tmoQjydW6d(RoeP5X~>{3i2dLM)<8BEa9{RhehN-cEQMW?mv*2nC?q5U_* zf673e-CygGM`kW$GRx!E@^`4AnF5`)4v3E5yQ@cS5dV2ns|RkUJUBN;((uSB;Ay>p z@aOzxrKuaqXhYV^V|Mpi|H8C>e}*Mw`ky4)rdG3cls?$bseHZZu!Yy76y#YVawkSV zc^gzm)jc32)cdt0u(F?4z7%aE=t*@1_GpJZdylMoK0bLV)f`rDOqo6Buq?J$ZZ_{~ zCSc;+?c>D;5x|eCsF3n0B>DzY0{R|Lk%)0pN(Eb;_vh=dU|T28Ujv)bl(@*JIPX#u zB7_5j+4^oo5cf;;jvJ`ZKtoE9`n+VkqvO>dPqEjE%(qH50{-OiAVFC1+2(efZ<~yF zBInrZr%w}2_sSIjV5;lr)&SeVS*JF~KX$UNlY53o)k(}O9^ z)>QwSv6(3yC=g23$bJku3ar!xjxqygD&6k29}1kEf%{yVP`|avaxT8Vn(F62yQJr) z);d|a-2W~8#x=5*dej-^~lFunR?*tTpl!? z3a*jZNWd1}HiK^?FkY0w)4BkLk}}b)*8VSI6!()CXRkr}IG5@sCMV;`^H+xX%snb;ewM(&8WN=vFqTiMa37Imbifnn23YNNfk6*Bn2Q#ztrGNO93 zUz~`NWQD3*JUBZepzX^qj0Yo`jGqs6hjUpdzJ2`ZX^Y~`VlgF4x|5;@PE*|iqx)~k zJIC6x~z6T-yjEktkMVM&p7hY1APWh4W z_V<9X0CMvEJVRdJY8|B^k>&9Pe-w-e$_Jp<8fV|%E-3YhOQ6so^J5yRenIe}v-1(< zR@nU&?TSwLH{yg?BLp}0N=;Ba*qWhnv2>a1YzDnt0b8*3v1#7;!E>0J`X5=`2?9#e zZ=B|AZ$ctcJPDKvKlsXz{*W+|tzd`|f@DnUcJP38T#A=b-k+7#5tvNVd{?)~Ez;T6 z=FxWAoWD0YfjIw93fd+QGKw(CcPE{pSD-UWvTrv|vMh604L*_Z-*jLE^TMi5w_b(LCEM>{s)PpA$#Y=+L%qk4Vp++O{dtu*hh zeRZ4S(`WC+rd%FzNN_wjzR^Wvs zp7H55TeGppkl?{-RJg~Ch?LQZ)30#Jm(>I3F zq!)Mh#unYxT3HnLE$jI~U0mU*)kmxeeMUkX#VNy_35=pY`u03$~;Q$&A z)fKge0*=7yQDJMrzpOI!me}7$l*>W-H(fC4Paj$CklooKxdY-jC@?^ zo`0ZEw`VC3ari3u&2!mrI4I_zctQj`hTsk|7srn-@%;3|I=ZrW2jaD8(w)z@s-|mJsF4K3{&#n*%A4*v9wCBa-hmeUT(SMHIeAZ44iBJd5555{@&vXAs_Vvx zdF;NSt~72?qtN&Nbf^B)*TRDkf~_pP|J?^GzDEaILjmjJ0NZlhu>XD_#kB

Tap.NONE Then + .Printer.Test(Result,, Description, .Directive, .Comment) + Else + .Printer.Test(Result,, Description) + .Success = .Success And Result + Endif + .Directive = Tap.NONE + .Comment = Null + End With + Return Result + +End + +Public Sub Todo(Optional Comment As String) + + $hCurrent.Directive = Tap.TODO + $hCurrent.Comment = Comment + +End + +Public Sub Skip(Optional Comment As String) + + $hCurrent.Directive = Tap.SKIP + $hCurrent.Comment = Comment + Me.Ok(True) + +End + +Public Sub Diagnostic(Comment As String) + + $hCurrent.Printer.Diagnostic(Comment) + +End + +Public Sub Print({Line} As String) + + $hCurrent.Printer.Print({Line}) + +End + +' -------------------- High-level test functions -------------------- + +Public Sub NotOk(Result As Boolean, Optional Description As String) As Boolean + + Return Ok(Not Result, Description) + +End + +Public Sub Equals(Got As Variant, Expected As Variant, Description As String) As Boolean + + Return Ok(Got = Expected, Description) + +End + +Public Sub LessEqual(Got As Variant, Bound As Variant, Description As String) As Boolean + + Return Ok(Got <= Bound, Description) + +End + +Public Sub Less(Got As Variant, Bound As Variant, Description As String) As Boolean + + Return Ok(Got < Bound, Description) + +End + +Public Sub GreaterEqual(Got As Variant, Bound As Variant, Description As String) As Boolean + + Return Ok(Got >= Bound, Description) + +End + +Public Sub Greater(Got As Variant, Bound As Variant, Description As String) As Boolean + + Return Ok(Got > Bound, Description) + +End + +Public Sub Approximate(Got As Float, Expected As Float, Precision As Float, Description As String) As Boolean + + Return Ok(Abs(Got - Expected) <= Precision, Description) + +End + +Public Sub RelativeApproximate(Got As Float, Expected As Float, RelPrecision As Float, Description As String) As Boolean + + Return Ok(Abs((Got - Expected) / Expected) <= RelPrecision, Description) + +End + +Public Sub IsType(Got As Variant, Type As Integer, Description As String) As Boolean + + Return Ok(TypeOf(Got) = Type, Description) + +End + +Public Sub Like(Got As String, Pattern As String, Description As String) As Boolean + + Return Ok(Got Like Pattern, Description) + +End + +Public Sub Match(Got As String, Pattern As String, Description As String) As Boolean + + Return Ok(Got Match Pattern, Description) + +End + +Public Sub StringEquals(Got As String, Expected As String, Description As String) As Boolean + + Dim bRes As Boolean + Dim iPos As Integer + + bRes = Equals(Got, Expected, Description) + If Not bRes Then + If Len(Got) <> Len(Expected) Then + Diagnostic("Strings are of different length.") + Diagnostic(" Got: " & Len(Got)) + Diagnostic(" Expected: " & Len(Expected)) + Endif + For iPos = 1 To Min(Len(Got), Len(Expected)) + If Mid$(Got, iPos, 1) <> Mid$(Expected, iPos, 1) Then Break + Next + Diagnostic("Strings differ at position " & iPos) + Diagnostic(" Got: " & Quote$(Mid$(Got, iPos, 20)) & IIf(Len(Got) > iPos + 20, "...", "")) + Diagnostic(" Expected: " & Quote$(Mid$(Expected, iPos, 20)) & IIf(Len(Expected) > iPos + 20, "...", "")) + Endif + Return bRes + +End + +' Public Sub EqualsDeeply() +' +' +' +' End diff --git a/comp/src/gb.test.tap/.src/Main.module b/comp/src/gb.test.tap/.src/Main.module new file mode 100644 index 000000000..ae76884ed --- /dev/null +++ b/comp/src/gb.test.tap/.src/Main.module @@ -0,0 +1,37 @@ +' Gambas module file + +Public Sub Main() + + Dim hProc As Process + Dim hHarness As New TestHarness + + hProc = Exec ["gbx3", "-s", "SampleTest", Application.Path] For Read + hHarness.Read(hProc, "SampleTest") + + With hHarness.Current + Dim sLine As String + Print "Transcript of the TAP stream:" + Print + Print String$(80, "*") + Print + For Each sLine In .Lines + Print sLine + Next + Print + Print String$(80, "*") + Print + + Print "Test";; .Name;; IIf(.Success, "PASSED", "FAILED");; "("; Format$(DateDiff(.Started, .Ended, gb.Second), "0.00s"); ")" + If .Run <> .Plan[1] Then Print "Planned";; .Plan[1];; "tests but ran";; .Run + If .Failed Then + Dim sFail As String + Print "Failed";; .Failed;; "out of";; .Run;; "tests:" + For Each sFail In .Failures + Print sFail + Next + Endif + If .BailedOut Then Print "Bailed out with message";; .BailMessage + If .Bonus Then Print "Passed";; .Bonus;; "additional tests marked as TODO" + End With + +End diff --git a/comp/src/gb.test.tap/.src/SampleTest.module b/comp/src/gb.test.tap/.src/SampleTest.module new file mode 100644 index 000000000..7f1c0e131 --- /dev/null +++ b/comp/src/gb.test.tap/.src/SampleTest.module @@ -0,0 +1,36 @@ +' Gambas module file + +Public Sub Main() + + With (Assert) + .Plan(4) + .Diagnostic("Starting tests!") + + .Subtest("Comparisons", 4) + .Greater(Now(), 0, "running after 1970") + + .Equals(System.Charset, "UTF-8", "system is UTF-8") + + .Diagnostic("Testing TODO directive") + .Todo("increase precision") + .Equals(Pi, 3.14, "Pi is 3.14") + + .StringEquals(System.Family, "Linux", "system is Linux") + + .Finish() + + .Todo("See a string comparison diagnostic") + .StringEquals(User.Home, "/home/tobias", "your home is my home") + + .IsType( Error , gb.Boolean, "Error keyword is a Boolean here") + + If Not Exist("/usr/bin/mountpoint") Then + .Skip("mountpoint utility is not installed") + Else + Dim sCapture As String + Exec ["/usr/bin/mountpoint", "/home"] To sCapture + .Equals(Process.LastValue, 0, "/home is a mountpoint") + Endif + End With + +End diff --git a/comp/src/gb.test.tap/.src/Tap/Tap.module b/comp/src/gb.test.tap/.src/Tap/Tap.module new file mode 100644 index 000000000..38130224d --- /dev/null +++ b/comp/src/gb.test.tap/.src/Tap/Tap.module @@ -0,0 +1,9 @@ +' Gambas module file + +Export + +' Plan +Public Const NO_PLAN As Integer = -1 + +' Directives +Public Enum NONE = 0, TODO = 1, SKIP diff --git a/comp/src/gb.test.tap/.src/Tap/TapParser.class b/comp/src/gb.test.tap/.src/Tap/TapParser.class new file mode 100644 index 000000000..3670a02ee --- /dev/null +++ b/comp/src/gb.test.tap/.src/Tap/TapParser.class @@ -0,0 +1,160 @@ +' Gambas class file + +''' Low-level parser for Test Anything Protocol ([TAP]) output. +''' It can only be used for one test process. +''' +''' [TAP]: http://testanything.org/tap-specification.html + +Export + +Event Version(Version As Integer) + +Event Plan(Start As Integer, {End} As Integer) + +Event Ok(TestNr As Integer, Description As String) +Event NotOk(TestNr As Integer, Description As String) +Event Todo(TestNr As Integer, Comment As String) +Event Skip(TestNr As Integer, Comment As String) + +Event BailOut(Comment As String) +Event Diagnostic(Comment As String) +Event Else({Line} As String) + +Private $iLine As Integer = 0 +Private $iTestsRun As Integer = 0 + +Public Sub Parse(TapStream As Stream) + + While Not Eof(TapStream) + ParseLine(TapStream.ReadLine()) + Wend + +End + +Public Sub ParseLine({Line} As String) + + Dim sLine As String = {Line} + Dim iVersion As Integer + + Dim bResult As Boolean + Dim iTestNr As Integer + Dim sDescription As String + Dim iDirective As Integer + Dim sComment As String + + If $iLine = 0 And If sLine Begins "TAP version " Then + Try iVersion = CInt(Trim$(Mid$(sLine, 13))) + ' At present a "TAP version" line is always an error: + ' 1. It might not be an integer, which is an error + ' 2. A version lower than 13 is an error by the specification + ' 3. We don't support version 13 or above. + If Error Then Error.Raise(Subst$(("Unrecognised TAP version '&1'"), Trim$(Mid$(sLine, 13)))) + If iVersion < 13 Then Error.Raise(Subst$(("Illegal TAP version '&1'"), iVersion)) + If iVersion > 12 Then Error.Raise(Subst$(("Unsupported TAP version &1"), iVersion)) + Endif + If $iLine = 0 Then Raise Version(12) + + If sLine Match "^\\d+..\\d+" Then + With Scan(sLine, "*..*") + If Not IsInteger(.[0]) Or If Not IsInteger(.[1]) Then Error.Raise(Subst$(("Couldn't extract test plan from '&1'"), sLine)) + Raise Plan(CInt(.[0]), CInt(.[1])) + End With + + Else If sLine Begins "ok" Or If sLine Begins "not ok" Then + bResult = ParseTest(sLine, ByRef iTestNr, ByRef sDescription, ByRef iDirective, ByRef sComment) + ' A single line may raise two events: Ok or NotOk, depending on the result + ' and Todo or Skip or none of the two depending on the directive. + ' Use the TestNr argument to link the two when counting tests for statistics. + If bResult Then + Raise Ok(iTestNr, sDescription) + Else + Raise NotOk(iTestNr, sDescription) + Endif + + If iDirective = Tap.TODO Then + Raise Todo(iTestNr, sComment) + Else If iDirective = Tap.SKIP Then + Raise Skip(iTestNr, sComment) + Endif + + Else If sLine Begins "Bail out!" Then + Raise BailOut(Trim$(Mid$(sLine, 10))) + + Else If sLine Begins "#" Then + Raise Diagnostic(Trim$(Mid$(sLine, 2))) + + Else + Raise Else(sLine) + Endif + + Inc $iLine + +End + +Private Function ParseTest(sLine As String, ByRef TestNr As Integer, ByRef Description As String, ByRef Directive As Integer, ByRef Comment As String) As Boolean + + Dim bResult As Boolean + Dim aWords As String[] + Dim sWord As String + + ' Tidy up caller's local variables + TestNr = 0 + Description = "" + Directive = Tap.NONE + Comment = "" + + Inc $iTestsRun + + ' "ok" or "not ok" + If sLine Begins "ok" Then + bResult = True + sLine = Trim$(Mid$(sLine, 3)) + Else If sLine Begins "not ok" + bResult = False + sLine = Trim$(Mid$(sLine, 7)) + Else + Error.Raise(Subst$(("Not a test line '&1'"), sLine)) + Endif + + ' Make sure that if a "#" occurs, it will be after a space + sLine = Replace$(sLine, "#", " #") + aWords = Split(sLine, " ", "", True).Reverse() + + ' TestNr + Try sWord = aWords.Pop() + Try TestNr = CInt(sWord) + If Error Then + aWords.Push(sWord) + TestNr = $iTestsRun + Endif + + ' Description + While aWords.Count + sWord = aWords.Pop() + If sWord Begins "#" Then Break + Description &= sWord & " " + Wend + Description = Trim$(Description) + + ' Directive + If sWord Begins "#" Then + If sWord = "#" Then + Try sWord = aWords.Pop() + If Error Then Error.Raise(("Premature end of directive")) + Endif + Select Case Lower$(sWord) + Case "todo" + Directive = Tap.TODO + Case "skip" + Directive = Tap.SKIP + Default + Error.Raise(Subst$(("Invalid directive '&1'"), sWord)) + End Select + Endif + + ' Comment + Comment = Trim$(aWords.Reverse().Join(" ")) + + Return bResult + +End diff --git a/comp/src/gb.test.tap/.src/Tap/TapPrinter.class b/comp/src/gb.test.tap/.src/Tap/TapPrinter.class new file mode 100644 index 000000000..710e4e2a9 --- /dev/null +++ b/comp/src/gb.test.tap/.src/Tap/TapPrinter.class @@ -0,0 +1,157 @@ +' Gambas class file + +''' Low-level class for planning and printing test results in Test Anything Protocol ([TAP]) format. +''' +''' [TAP]: http://testanything.org/tap-specification.html + +Export + +Event Filter + +Property {Output} As Stream +Property Read Planned As Integer +Property Read Count As Integer +Property Read Last As Integer +Property Line As String + +Private $hOutput As Stream +Private $iPlan As Integer +Private $iTestsRun As Integer +Private $iLast As Integer +Private $bFinished As Boolean +Private $sLine As String + +Public Sub _new(Optional Tests As Integer, Optional Comment As String, Optional {Output} As Stream = File.Out) + + $hOutput = {Output} + $iPlan = Tap.NO_PLAN + $iTestsRun = 0 + $iLast = 0 + $bFinished = False + If Not IsMissing(Tests) Then Plan(Tests, Comment) + +End + +Public Sub Plan(Tests As Integer, Optional Comment As String) + + If $iTestsRun Then Error.Raise(Subst$(("Too late to plan. Already ran &1 tests"), $iTestsRun)) + ' TAP specification lists '1..0 # Skipped: WWW::Mechanize not installed' + ' as a valid example. + If Tests <= Tap.NO_PLAN Then Error.Raise(("Number of tests must be non-negative")) + $iPlan = Tests + Print(Subst$("1..&1&2", $iPlan, IIf(Comment, " # " & Comment, ""))) + +End + +Public Sub Finish() + + If $iPlan > Tap.NO_PLAN Then Return ' already printed the "plan" line + If $bFinished Then Error.Raise(("Tests already finished")) + $iPlan = $iTestsRun + Print("1.." & $iPlan) + $bFinished = True + +End + +Public Sub Test(Result As Boolean, Optional TestNr As Integer, Optional Description As String, Optional Directive As Integer, Optional Comment As String) + + Dim sDirective As String + Dim sLine As String + + If $bFinished Then Error.Raise(("Tests already finished")) + + ' It is not advised to start a description with a number token because + ' it will be interpreted as the (optional) test number. We issue a warning + ' about this but fix it anyway by always printing the TestNr before *and* + ' prefixing the Description with a dash, as is common. + If Description Match "^[0-9]+(\\s|$)" Then + Error Subst$(("Warning: Description '&1' should not start with a number"), Description) + Endif + If Description Like "*#*" Then + Error.Raise(Subst$(("Description '&1' may not contain a '#' character"), Description)) + Endif + + Inc $iTestsRun + If Not TestNr Then TestNr = $iTestsRun + $iLast = TestNr + sLine = Subst$("&1 &2 - &3", IIf(Result, "ok", "not ok"), TestNr, Description) + + If Not IsMissing(Directive) Then + ' Matches the values of the Enum Tap.Todo, Tap.Skip + sDirective = Choose(Directive, "TODO", "SKIP") + If Not sDirective Then Error.Raise(Subst$(("Unsupported directive '&1'"), Directive)) + sLine &= " # " & sDirective + If Comment Then sLine &= " " & Comment + Endif + + Print(sLine) + +End + +Public Sub BailOut(Optional Comment As String) + + If $bFinished Then Error.Raise(("Tests already finished")) + Print("Bail out!" & IIf(Comment, " " & Comment, "")) + $bFinished = True + +End + +Public Sub Diagnostic(Comment As String) + + Print("# " & Comment) + +End + +Public Sub Print({Line} As String) + + Dim bCancel As Boolean + + $sLine = {Line} + bCancel = Raise Filter + If bCancel Then Return + Print #$hOutput, $sLine + Flush #$hOutput + +End + +Private Function Output_Read() As Stream + + Return $hOutput + +End + +Private Sub Output_Write(Value As Stream) + + $hOutput = Value + +End + +Private Function Planned_Read() As Integer + + Return $iPlan + +End + +Private Function Count_Read() As Integer + + Return $iTestsRun + +End + +Private Function Last_Read() As Integer + + Return $iLast + +End + +Private Function Line_Read() As String + + Return $sLine + +End + +Private Sub Line_Write(Value As String) + + $sLine = Value + +End diff --git a/comp/src/gb.test.tap/.src/TestHarness.class b/comp/src/gb.test.tap/.src/TestHarness.class new file mode 100644 index 000000000..bc2b8ce18 --- /dev/null +++ b/comp/src/gb.test.tap/.src/TestHarness.class @@ -0,0 +1,213 @@ +' Gambas class file + +''' Base class for a test harness. It collects statistics about the tests, inspired by perl's Test::Harness. + +Export + +Public Struct TestStats + '' Name of the test + Name As String + '' Exit status of the test process + ExitCode As Integer + '' Whether the test was successful (all tests passed and at least one test was executed) + Success As Boolean + '' Number of run tests + Run As Integer + '' Difference between planned and run tests + Delta As Integer + '' Whether the test bailed out (aborted gracefully) + BailedOut As Boolean + '' If BailedOut, this contains the optional attached message + BailMessage As String + '' When the test started + Started As Date + '' When the test ended + Ended As Date + + '' TAP version in use + Version As Integer + '' Number of tests planned + Planned As Integer + '' Test range + Plan As Integer[] + '' Number of successful tests (not accounting for Todo or Skipped ones) + Passed As Integer + '' Number of failed tests (not accounting for Todo or Skipped ones) + Failed As Integer + '' Number of tested marked as to-do + Todo As Integer + '' Number of skipped tests + Skipped As Integer + '' Number of Todo tests which passed + Bonus As Integer + + '' Descriptions of failed tests + Failures As String[] + + '' A copy of the TAP stream + Lines As String[] +End Struct + +Property Read Tests As TestStats[] +Property Read Current As TestStats +Property Read Finished As Boolean + +Private $hProducer As Process +Private $hParser As TapParser +Private $aTests As New TestStats[] +Private $hCurrent As TestStats +Private $bLastOk As Boolean + +Public Sub Attach(Producer As Process, Name As String) + + $hProducer = Producer + Object.Attach(Producer, Me, "TapStream") + + ' XXX: If a class inherits this, it can override/claim event handlers and our statistics aren't accurate. + $hParser = New TapParser As "Parser" + + $hCurrent = New TestStats + $hCurrent.Name = Name + $hCurrent.Plan = [1, 0] + $hCurrent.Failures = New String[] + $hCurrent.Lines = New String[] + $hCurrent.Started = Now() + + $aTests.Push($hCurrent) + + ' Catch + ' Debug Subst$(("Test harness failure: [&1] &2"), Error.Where, Error.Text) + ' Debug Error.Backtrace.Join("\n") + ' Error.Raise(Subst$(("Test harness failure: [&1] &2"), Error.Where, Error.Text)) + +End + +Public Sub Wait() + + $hProducer.Wait() + +End + +Public Sub Read(Producer As Process, Name As String) + + Me.Attach(Producer, Name) + Me.Wait() + +End + +Public Sub TapStream_Read() + + Dim sLine As String = Last.ReadLine() + + $hCurrent.Lines.Add(sLine) + $hParser.ParseLine(sLine) + +End + +Public Sub TapStream_Error(Message As String) + + Dim sLine As String + + ' Inject stderr as diagnostic messages + For Each sLine In Split(Message, "\n") + sLine = "# " & sLine + $hCurrent.Lines.Add(sLine) + $hParser.ParseLine(sLine) + Next + +End + +Public Sub TapStream_Kill() + + With $hCurrent + .Ended = Now() + .ExitCode = Last.Value + .Run = .Passed + .Failed + .Todo + .Skipped + .Delta = .Planned - .Run + .Success = .ExitCode = 0 And .Planned > 0 And .Run = .Planned And .Failed = 0 + End With + +End + +Public Sub Parser_Version(Version As Integer) + + $hCurrent.Version = Version + +End + +Public Sub Parser_Plan(Start As Integer, {End} As Integer) + + $hCurrent.Plan = [Start, {End}] + $hCurrent.Planned = 1 + {End} - Start + +End + +Public Sub Parser_Ok(TestNr As Integer, Description As String) + + Inc $hCurrent.Passed + $bLastOk = True + +End + +Public Sub Parser_NotOk(TestNr As Integer, Description As String) + + Inc $hCurrent.Failed + $hCurrent.Failures.Push(Description) + $bLastOk = False + +End + +'' Undoes the last increment. Used to correct the count of passed/failed +'' tests for Todo and Skip events. +Private Sub UndoOk() + + If $bLastOk Then + Dec $hCurrent.Passed + Else + Dec $hCurrent.Failed + $hCurrent.Failures.Pop() + Endif + +End + +Public Sub Parser_Todo(TestNr As Integer, Comment As String) + + UndoOk() + Inc $hCurrent.Todo + If $bLastOk Then Inc $hCurrent.Bonus + +End + +Public Sub Parser_Skip(TestNr As Integer, Comment As String) + + UndoOk() + Inc $hCurrent.Skipped + +End + +Public Sub Parser_BailOut(Comment As String) + + $hCurrent.BailedOut = True + $hCurrent.BailMessage = Comment + +End + +' Diagnostic and Else messages are not handled here. + +Private Function Tests_Read() As TestStats[] + + Return $aTests + +End + +Private Function Current_Read() As TestStats + + Return $hCurrent + +End + +Private Function Finished_Read() As Boolean + + Return $hProducer.State <> Process.Running + +End diff --git a/comp/src/order b/comp/src/order index 5016be470..eb22cf6f4 100644 --- a/comp/src/order +++ b/comp/src/order @@ -1 +1 @@ -gb.eval.highlight gb.args gb.settings gb.gui.base gb.form gb.form.stock gb.form.dialog gb.form.mdi gb.db.form gb.desktop gb.web gb.report gb.report2 gb.chart gb.mysql gb.net.smtp gb.net.pop3 gb.memcached gb.map gb.logging gb.markdown gb.media.form gb.util gb.util.web gb.form.editor gb.dbus.trayicon gb.web.form gb.web.form2 gb.form.terminal gb.term.form gb.web.feed gb.form.print gb.scanner gb.test +gb.eval.highlight gb.args gb.settings gb.gui.base gb.form gb.form.stock gb.form.dialog gb.form.mdi gb.db.form gb.desktop gb.web gb.report gb.report2 gb.chart gb.mysql gb.net.smtp gb.net.pop3 gb.memcached gb.map gb.logging gb.markdown gb.media.form gb.util gb.util.web gb.form.editor gb.dbus.trayicon gb.web.form gb.web.form2 gb.form.terminal gb.term.form gb.web.feed gb.form.print gb.scanner gb.test.tap gb.test